From 7d6dcc32a38e50175e6aafe0259f6cdf4ae035e8 Mon Sep 17 00:00:00 2001
From: Heinrich Apfelmus <apfelmus@quantentunnel.de>
Date: Sat, 3 Aug 2013 23:25:34 +0200
Subject: [PATCH 01/41] Reorder server code to isolate FFI implementation.

---
 src/Graphics/UI/Threepenny/Internal/Core.hs | 356 ++++++++++----------
 1 file changed, 182 insertions(+), 174 deletions(-)

diff --git a/src/Graphics/UI/Threepenny/Internal/Core.hs b/src/Graphics/UI/Threepenny/Internal/Core.hs
index 21296a04..4c76026f 100644
--- a/src/Graphics/UI/Threepenny/Internal/Core.hs
+++ b/src/Graphics/UI/Threepenny/Internal/Core.hs
@@ -2,14 +2,11 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# OPTIONS -fno-warn-name-shadowing #-}
 
--- | The main Threepenny module.
-
-
---------------------------------------------------------------------------------
--- Exports
-
 module Graphics.UI.Threepenny.Internal.Core
   (
+  -- * Synopsis
+  -- | The main internal functionality.
+      
   -- * Server running
    serve
   ,loadFile
@@ -108,7 +105,7 @@ import           Text.JSON.Generic
 
 
 {-----------------------------------------------------------------------------
-    Server running
+    Server and and session management
 ------------------------------------------------------------------------------}
 newServerState :: IO ServerState
 newServerState = ServerState 
@@ -118,12 +115,14 @@ newServerState = ServerState
 
 -- | Run a TP server with Snap on the specified port and the given
 --   worker action.
-serve :: Config -> (Session -> IO ()) -> IO () -- ^ A TP server.
+serve :: Config -> (Session -> IO ()) -> IO ()
 serve Config{..} worker = do
-  server <- newServerState
-  _ <- forkIO $ custodian 30 (sSessions server)
-  httpServe config (router tpCustomHTML tpStatic worker server)
- where config = setPort tpPort defaultConfig
+    server <- newServerState
+    _      <- forkIO $ custodian 30 (sSessions server)
+    let config = setPort tpPort defaultConfig
+    httpServe config . route $
+        routeResources tpCustomHTML tpStatic server
+        ++ routeFFI worker server
 
 -- | Kill sessions after at least n seconds of disconnectedness.
 custodian :: Integer -> MVar Sessions -> IO ()
@@ -144,32 +143,181 @@ custodian seconds sessions = forever $ do
             
     return (M.filterWithKey (\k _ -> not (k `elem` killed)) sessions)
 
--- Route requests.  If the initFile is Nothing, then a default
--- file will be served at /.
-router
-    :: Maybe FilePath
-    -> FilePath
-    -> (Session -> IO a)
-    -> ServerState
-    -> Snap ()
-router customHTML wwwroot worker server =
-        route [("/static"                    , serveDirectory wwwroot)
-              ,("/"                          , root)
-              ,("/driver/threepenny-gui.js"  , writeText jsDriverCode )
-              ,("/driver/threepenny-gui.css" , writeText cssDriverCode)
-              ,("/init"                      , init worker server)
-              ,("/poll"                      , withSession  server poll  )
-              ,("/signal"                    , withSession  server signal)
-              ,("/file/:name"                ,
-                    withFilepath (sFiles server) (flip serveFileAs))
-              ,("/dir/:name"                 ,
-                    withFilepath (sDirs  server) (\path _ -> serveDirectory path))
-              ]
+-- | Route the communication between JavaScript and the server
+routeFFI :: (Session -> IO a) -> ServerState -> Routes
+routeFFI worker server =
+    [("/init"   , init worker server)
+    ,("/poll"   , withSession server poll  )
+    ,("/signal" , withSession server signal)
+    ]
+
+-- Run a snap action with the given session.
+withSession :: ServerState -> (Session -> Snap a) -> Snap a
+withSession server cont = do
+    token <- readInput "token"
+    case token of
+        Nothing    -> error $ "Invalid session token format."
+        Just token -> withGivenSession token server cont
+    
+-- Do something with the session given by its token id.
+withGivenSession :: Integer -> ServerState -> (Session -> Snap a) -> Snap a
+withGivenSession token ServerState{..} cont = do
+    sessions <- io $ withMVar sSessions return
+    case M.lookup token sessions of
+        Nothing -> error $ "Nonexistant token: " ++ show token
+        Just session -> cont session
+
+{-----------------------------------------------------------------------------
+    FFI communication
+------------------------------------------------------------------------------}
+-- Make a new session.
+newSession :: ServerState -> (URI,[(String, String)]) -> Integer -> IO Session
+newSession server info token = do
+    signals          <- newChan
+    instructions     <- newChan
+    (event, handler) <- newEventsTagged
+    ids      <- newMVar [0..]
+    mutex    <- newMVar ()
+    now      <- getCurrentTime
+    conState <- newMVar (Disconnected now)
+    threadId <- myThreadId
+    closures <- newMVar [0..]
+    return $ Session
+        { sSignals = signals
+        , sInstructions = instructions
+        , sEvent        = event
+        , sEventHandler = handler
+        , sElementIds = ids
+        , sToken = token
+        , sMutex = mutex
+        , sConnectedState = conState
+        , sThreadId    = threadId
+        , sClosures    = closures
+        , sStartInfo   = info
+        , sServerState = server
+        }
+
+-- Initialize the session.
+init :: (Session -> IO void) -> ServerState -> Snap ()
+init sessionThread server = do
+    uri    <- getRequestURI
+    params <- getRequestCookies
+    key    <- io $ modifyMVar (sSessions server) $ \sessions -> do
+        let newKey = maybe 0 (+1) (lastMay (M.keys sessions))
+        session <- newSession server (uri,params) newKey
+        _       <- forkIO $ do _ <- sessionThread session; return ()
+        return (M.insert newKey session sessions,newKey)
+    modifyResponse $ setHeader "Set-Token" (fromString (show key))
+    withGivenSession key server poll
+  where
+  getRequestURI = do
+    uri     <- getInput "info"
+    maybe (error ("Unable to parse request URI: " ++ show uri)) return (uri >>= parseURI)
+  getRequestCookies = do
+    cookies <- getsRequest rqCookies
+    return $ flip map cookies $ \Cookie{..} -> (toString cookieName,toString cookieValue)
+  
+-- Respond to poll requests.
+poll :: Session -> Snap ()
+poll Session{..} = do
+    let setDisconnected = do
+        now <- getCurrentTime
+        modifyMVar_ sConnectedState (const (return (Disconnected now)))
+    io $ modifyMVar_ sConnectedState (const (return Connected))
+    threadId <- io $ myThreadId
+    _ <- io $ forkIO $ do
+        delaySeconds $ 60 * 5 -- Force kill after 5 minutes.
+        killThread threadId
+    instructions <- io $ E.catch (readAvailableChan sInstructions) $ \e -> do
+        when (e == E.ThreadKilled) $ do
+            setDisconnected
+        E.throw e
+    writeJson instructions
+
+-- Handle signals sent from the client.
+signal :: Session -> Snap ()
+signal Session{..} = do
+    input <- getInput "signal"
+    case input of
+      Just signalJson -> do
+        let signal = decode signalJson
+        case signal of
+          Ok signal -> io $ writeChan sSignals signal
+          Error err -> error err
+      Nothing -> error $ "Unable to parse " ++ show input
+
+
+-- | Atomically execute the given computation in the context of a browser window
+atomic :: Window -> IO a -> IO a
+atomic window@(Session{..}) m = do
+  takeMVar sMutex
+  ret <- m
+  putMVar sMutex ()
+  return ret
+
+
+-- Send an instruction and read the signal response.
+call :: Session -> Instruction -> (Signal -> IO (Maybe a)) -> IO a
+call session@(Session{..}) instruction withSignal = do
+  takeMVar sMutex
+  run session $ instruction
+  newChan <- dupChan sSignals
+  go sMutex newChan
+
+  where
+    go mutex newChan = do
+      signal <- readChan newChan
+      result <- withSignal signal
+      case result of
+        Just signal -> do putMVar mutex ()
+                          return signal
+        Nothing     -> go mutex newChan
+            -- keep reading signals from the duplicated channel
+            -- until the function above succeeds
+
+-- Run the given instruction wihtout waiting for a response.
+run :: Session -> Instruction -> IO ()
+run (Session{..}) i = writeChan sInstructions i
+
+{-----------------------------------------------------------------------------
+    Snap utilities
+------------------------------------------------------------------------------}
+-- Write JSON to output.
+writeJson :: (MonadSnap m, JSON a) => a -> m ()
+writeJson json = do
+    modifyResponse $ setContentType "application/json"
+    (writeText . pack . (\x -> showJSValue x "") . showJSON) json
+
+-- Get a text input from snap.
+getInput :: (MonadSnap f) => ByteString -> f (Maybe String)
+getInput = fmap (fmap (unpack . decodeUtf8)) . getParam
+
+-- Read an input from snap.
+readInput :: (MonadSnap f,Read a) => ByteString -> f (Maybe a)
+readInput = fmap (>>= readMay) . getInput
+
+{-----------------------------------------------------------------------------
+    Resourcse
+------------------------------------------------------------------------------}
+type Routes = [(ByteString, Snap ())]
+
+routeResources :: Maybe FilePath -> FilePath -> ServerState -> Routes
+routeResources customHTML staticDir server =
+    [("/static"                    , serveDirectory staticDir)
+    ,("/"                          , root)
+    ,("/driver/threepenny-gui.js"  , writeText jsDriverCode )
+    ,("/driver/threepenny-gui.css" , writeText cssDriverCode)
+    ,("/file/:name"                ,
+        withFilepath (sFiles server) (flip serveFileAs))
+    ,("/dir/:name"                 ,
+        withFilepath (sDirs  server) (\path _ -> serveDirectory path))
+    ]
     where
     root = case customHTML of
-        Just file -> serveFile (wwwroot </> file)
+        Just file -> serveFile (staticDir </> file)
         Nothing   -> writeText defaultHtmlFile
 
+
 -- Get a filename from a URI
 withFilepath :: MVar Filepaths -> (FilePath -> MimeType -> Snap a) -> Snap a
 withFilepath rDict cont = do
@@ -202,116 +350,6 @@ loadDirectory Session{..} path = do
     key <- newAssociation (sDirs sServerState) (path,"")
     return $ "/dir/" ++ key
 
--- Initialize the session.
-init :: (Session -> IO void) -> ServerState -> Snap ()
-init sessionThread server = do
-  uri <- getRequestURI
-  params <- getRequestCookies
-  key <- io $ modifyMVar (sSessions server) $ \sessions -> do
-    let newKey = maybe 0 (+1) (lastMay (M.keys sessions))
-    session <- newSession server (uri,params) newKey
-    _ <- forkIO $ do _ <- sessionThread session; return ()
-    return (M.insert newKey session sessions,newKey)
-  modifyResponse $ setHeader "Set-Token" (fromString (show key))
-  withGivenSession key server poll
-    
-  where getRequestURI = do
-          uri <- getInput "info"
-          maybe (error ("Unable to parse request URI: " ++ show uri)) return (uri >>= parseURI)
-        getRequestCookies = do
-          cookies <- getsRequest rqCookies
-          return $ flip map cookies $ \Cookie{..} -> (toString cookieName,toString cookieValue)
-
--- Make a new session.
-newSession :: ServerState -> (URI,[(String, String)]) -> Integer -> IO Session
-newSession server info token = do
-  signals <- newChan
-  instructions <- newChan
-  (event, handler) <- newEventsTagged
-  ids <- newMVar [0..]
-  mutex <- newMVar ()
-  now <- getCurrentTime
-  conState <- newMVar (Disconnected now)
-  threadId <- myThreadId
-  closures <- newMVar [0..]
-  return $ Session
-    { sSignals = signals
-    , sInstructions = instructions
-    , sEvent        = event
-    , sEventHandler = handler
-    , sElementIds = ids
-    , sToken = token
-    , sMutex = mutex
-    , sConnectedState = conState
-    , sThreadId    = threadId
-    , sClosures    = closures
-    , sStartInfo   = info
-    , sServerState = server
-    }
-  
--- Respond to poll requests.
-poll :: Session -> Snap ()
-poll Session{..} = do
-  let setDisconnected = do
-        now <- getCurrentTime
-        modifyMVar_ sConnectedState (const (return (Disconnected now)))
-  io $ modifyMVar_ sConnectedState (const (return Connected))
-  threadId <- io $ myThreadId
-  _ <- io $ forkIO $ do
-    delaySeconds $ 60 * 5 -- Force kill after 5 minutes.
-    killThread threadId
-  instructions <- io $ E.catch (readAvailableChan sInstructions) $ \e -> do
-    when (e == E.ThreadKilled) $ do
-      setDisconnected
-    E.throw e
-  writeJson instructions
-
--- Write JSON to output.
-writeJson :: (MonadSnap m, JSON a) => a -> m ()
-writeJson json = do
-    modifyResponse $ setContentType "application/json"
-    (writeString . (\x -> showJSValue x "") . showJSON) json
-
--- Write a string to output.
-writeString :: (MonadSnap m) => String -> m ()
-writeString = writeText . pack
-
--- Handle signals sent from the client.
-signal :: Session -> Snap ()
-signal Session{..} = do
-    input <- getInput "signal"
-    case input of
-      Just signalJson -> do
-        let signal = decode signalJson
-        case signal of
-          Ok signal -> io $ writeChan sSignals signal
-          Error err -> error err
-      Nothing -> error $ "Unable to parse " ++ show input
-
--- Get a text input from snap.
-getInput :: (MonadSnap f) => ByteString -> f (Maybe String)
-getInput = fmap (fmap (unpack . decodeUtf8)) . getParam
-
--- Run a snap action with the given session.
-withSession :: ServerState -> (Session -> Snap a) -> Snap a
-withSession server cont = do
-  token <- readInput "token"
-  case token of
-    Nothing    -> error $ "Invalid session token format."
-    Just token -> withGivenSession token server cont
-    
--- Do something with the session given by its token id.
-withGivenSession :: Integer -> ServerState -> (Session -> Snap a) -> Snap a
-withGivenSession token ServerState{..} cont = do
-  sessions <- io $ withMVar sSessions return
-  case M.lookup token sessions of
-    Nothing -> error $ "Nonexistant token: " ++ show token
-    Just session -> cont session
-
--- Read an input from snap.
-readInput :: (MonadSnap f,Read a) => ByteString -> f (Maybe a)
-readInput = fmap (>>= readMay) . getInput
-
 
 {-----------------------------------------------------------------------------
     Event handling
@@ -538,36 +576,6 @@ readValuesList
     -> IO (Maybe [a]) -- ^ Maybe the read values. All or none.
 readValuesList = liftM (sequence . map readMay) . getValuesList
 
--- | Atomically execute the given computation in the context of a browser window
-atomic :: Window -> IO a -> IO a
-atomic window@(Session{..}) m = do
-  takeMVar sMutex
-  ret <- m
-  putMVar sMutex ()
-  return ret
-
-
--- Send an instruction and read the signal response.
-call :: Session -> Instruction -> (Signal -> IO (Maybe a)) -> IO a
-call session@(Session{..}) instruction withSignal = do
-  takeMVar sMutex
-  run session $ instruction
-  newChan <- dupChan sSignals
-  go sMutex newChan
-
-  where
-    go mutex newChan = do
-      signal <- readChan newChan
-      result <- withSignal signal
-      case result of
-        Just signal -> do putMVar mutex ()
-                          return signal
-        Nothing     -> go mutex newChan
-
--- Run the given instruction.
-run :: Session -> Instruction -> IO ()
-run (Session{..}) i = writeChan sInstructions i
-
 -- | Get the head of the page.
 getHead :: Window -> IO Element
 getHead session = return $ Element (ElementId "head") session

From ccb538c90a2575bea6a919ab57f0e5adcb552304 Mon Sep 17 00:00:00 2001
From: Heinrich Apfelmus <apfelmus@quantentunnel.de>
Date: Sat, 3 Aug 2013 23:34:45 +0200
Subject: [PATCH 02/41] Reorder some more to isolate implementation of the
 two-way communication channel.

---
 src/Graphics/UI/Threepenny/Internal/Core.hs  | 101 ++++++++++---------
 src/Graphics/UI/Threepenny/Internal/Types.hs |   2 +-
 2 files changed, 53 insertions(+), 50 deletions(-)

diff --git a/src/Graphics/UI/Threepenny/Internal/Core.hs b/src/Graphics/UI/Threepenny/Internal/Core.hs
index 4c76026f..e6bafdeb 100644
--- a/src/Graphics/UI/Threepenny/Internal/Core.hs
+++ b/src/Graphics/UI/Threepenny/Internal/Core.hs
@@ -122,7 +122,7 @@ serve Config{..} worker = do
     let config = setPort tpPort defaultConfig
     httpServe config . route $
         routeResources tpCustomHTML tpStatic server
-        ++ routeFFI worker server
+        ++ routeCommunication worker server
 
 -- | Kill sessions after at least n seconds of disconnectedness.
 custodian :: Integer -> MVar Sessions -> IO ()
@@ -143,14 +143,6 @@ custodian seconds sessions = forever $ do
             
     return (M.filterWithKey (\k _ -> not (k `elem` killed)) sessions)
 
--- | Route the communication between JavaScript and the server
-routeFFI :: (Session -> IO a) -> ServerState -> Routes
-routeFFI worker server =
-    [("/init"   , init worker server)
-    ,("/poll"   , withSession server poll  )
-    ,("/signal" , withSession server signal)
-    ]
-
 -- Run a snap action with the given session.
 withSession :: ServerState -> (Session -> Snap a) -> Snap a
 withSession server cont = do
@@ -158,7 +150,7 @@ withSession server cont = do
     case token of
         Nothing    -> error $ "Invalid session token format."
         Just token -> withGivenSession token server cont
-    
+
 -- Do something with the session given by its token id.
 withGivenSession :: Integer -> ServerState -> (Session -> Snap a) -> Snap a
 withGivenSession token ServerState{..} cont = do
@@ -168,9 +160,17 @@ withGivenSession token ServerState{..} cont = do
         Just session -> cont session
 
 {-----------------------------------------------------------------------------
-    FFI communication
+    Implementation of two-way communication
 ------------------------------------------------------------------------------}
--- Make a new session.
+-- | Route the communication between JavaScript and the server
+routeCommunication :: (Session -> IO a) -> ServerState -> Routes
+routeCommunication worker server =
+    [("/init"   , init worker server)
+    ,("/poll"   , withSession server poll  )
+    ,("/signal" , withSession server signal)
+    ]
+
+-- | Make a new session.
 newSession :: ServerState -> (URI,[(String, String)]) -> Integer -> IO Session
 newSession server info token = do
     signals          <- newChan
@@ -183,13 +183,13 @@ newSession server info token = do
     threadId <- myThreadId
     closures <- newMVar [0..]
     return $ Session
-        { sSignals = signals
+        { sSignals      = signals
         , sInstructions = instructions
+        , sMutex        = mutex
         , sEvent        = event
         , sEventHandler = handler
         , sElementIds = ids
         , sToken = token
-        , sMutex = mutex
         , sConnectedState = conState
         , sThreadId    = threadId
         , sClosures    = closures
@@ -197,7 +197,7 @@ newSession server info token = do
         , sServerState = server
         }
 
--- Initialize the session.
+-- | Initialize the session.
 init :: (Session -> IO void) -> ServerState -> Snap ()
 init sessionThread server = do
     uri    <- getRequestURI
@@ -217,7 +217,7 @@ init sessionThread server = do
     cookies <- getsRequest rqCookies
     return $ flip map cookies $ \Cookie{..} -> (toString cookieName,toString cookieValue)
   
--- Respond to poll requests.
+-- | Respond to poll requests.
 poll :: Session -> Snap ()
 poll Session{..} = do
     let setDisconnected = do
@@ -234,7 +234,7 @@ poll Session{..} = do
         E.throw e
     writeJson instructions
 
--- Handle signals sent from the client.
+-- | Handle signals sent from the client.
 signal :: Session -> Snap ()
 signal Session{..} = do
     input <- getInput "signal"
@@ -247,6 +247,9 @@ signal Session{..} = do
       Nothing -> error $ "Unable to parse " ++ show input
 
 
+{-----------------------------------------------------------------------------
+    FFI implementation on top of the communication channel
+------------------------------------------------------------------------------}
 -- | Atomically execute the given computation in the context of a browser window
 atomic :: Window -> IO a -> IO a
 atomic window@(Session{..}) m = do
@@ -255,8 +258,7 @@ atomic window@(Session{..}) m = do
   putMVar sMutex ()
   return ret
 
-
--- Send an instruction and read the signal response.
+-- | Send an instruction and read the signal response.
 call :: Session -> Instruction -> (Signal -> IO (Maybe a)) -> IO a
 call session@(Session{..}) instruction withSignal = do
   takeMVar sMutex
@@ -279,6 +281,37 @@ call session@(Session{..}) instruction withSignal = do
 run :: Session -> Instruction -> IO ()
 run (Session{..}) i = writeChan sInstructions i
 
+-- | Call the given function with the given continuation. Doesn't block.
+callDeferredFunction
+  :: Window                    -- ^ Browser window
+  -> String                    -- ^ The function name.
+  -> [String]                  -- ^ Parameters.
+  -> ([Maybe String] -> IO ()) -- ^ The continuation to call if/when the function completes.
+  -> IO ()
+callDeferredFunction session@(Session{..}) func params closure = do
+  cid      <- modifyMVar sClosures (\(x:xs) -> return (xs,x))
+  closure' <- newClosure session func (show cid) closure
+  run session $ CallDeferredFunction (closure',func,params)
+
+-- | Run the given JavaScript function and carry on. Doesn't block.
+--
+-- The client window uses JavaScript's @eval()@ function to run the code.
+runFunction :: Window -> JSFunction () -> IO ()
+runFunction session = run session . RunJSFunction . unJSCode . code
+
+-- | Run the given JavaScript function and wait for results. Blocks.
+--
+-- The client window uses JavaScript's @eval()@ function to run the code.
+callFunction :: Window -> JSFunction a -> IO a
+callFunction window (JSFunction code marshal) = 
+    call window (CallJSFunction . unJSCode $ code) $ \signal ->
+        case signal of
+            FunctionResult v -> case marshal window v of
+                Ok    a -> return $ Just a
+                Error _ -> return Nothing
+            _ -> return Nothing
+
+
 {-----------------------------------------------------------------------------
     Snap utilities
 ------------------------------------------------------------------------------}
@@ -606,33 +639,3 @@ debug window = run window . Debug
 -- | Clear the client's DOM.
 clear :: Window -> IO ()
 clear window = run window $ Clear ()
-
--- | Run the given JavaScript function and carry on. Doesn't block.
---
--- The client window uses JavaScript's @eval()@ function to run the code.
-runFunction :: Window -> JSFunction () -> IO ()
-runFunction session = run session . RunJSFunction . unJSCode . code
-
--- | Run the given JavaScript function and wait for results. Blocks.
---
--- The client window uses JavaScript's @eval()@ function to run the code.
-callFunction :: Window -> JSFunction a -> IO a
-callFunction window (JSFunction code marshal) = 
-    call window (CallJSFunction . unJSCode $ code) $ \signal ->
-        case signal of
-            FunctionResult v -> case marshal window v of
-                Ok    a -> return $ Just a
-                Error _ -> return Nothing
-            _ -> return Nothing
-
--- | Call the given function with the given continuation. Doesn't block.
-callDeferredFunction
-  :: Window                    -- ^ Browser window
-  -> String                    -- ^ The function name.
-  -> [String]                  -- ^ Parameters.
-  -> ([Maybe String] -> IO ()) -- ^ The continuation to call if/when the function completes.
-  -> IO ()
-callDeferredFunction session@(Session{..}) func params closure = do
-  cid      <- modifyMVar sClosures (\(x:xs) -> return (xs,x))
-  closure' <- newClosure session func (show cid) closure
-  run session $ CallDeferredFunction (closure',func,params)
diff --git a/src/Graphics/UI/Threepenny/Internal/Types.hs b/src/Graphics/UI/Threepenny/Internal/Types.hs
index 052c156a..f77387ce 100644
--- a/src/Graphics/UI/Threepenny/Internal/Types.hs
+++ b/src/Graphics/UI/Threepenny/Internal/Types.hs
@@ -44,12 +44,12 @@ instance JSON ElementId where
 data Session = Session
   { sSignals        :: Chan Signal
   , sInstructions   :: Chan Instruction
+  , sMutex          :: MVar ()
   , sEvent          :: EventKey -> E.Event EventData
   , sEventHandler   :: E.Handler (EventKey, EventData)
   , sClosures       :: MVar [Integer]
   , sElementIds     :: MVar [Integer]
   , sToken          :: Integer
-  , sMutex          :: MVar ()
   , sConnectedState :: MVar ConnectedState
   , sThreadId       :: ThreadId
   , sStartInfo      :: (URI,[(String,String)])

From 08c25a14f0f47c2e2476ea19f8b91e3150ec9a90 Mon Sep 17 00:00:00 2001
From: Heinrich Apfelmus <apfelmus@quantentunnel.de>
Date: Sun, 4 Aug 2013 12:00:17 +0200
Subject: [PATCH 03/41] Refactor communication slightly in preparation for
 WebSocket implementation.

---
 src/Graphics/UI/Threepenny/Internal/Core.hs | 49 ++++++++++++---------
 1 file changed, 29 insertions(+), 20 deletions(-)

diff --git a/src/Graphics/UI/Threepenny/Internal/Core.hs b/src/Graphics/UI/Threepenny/Internal/Core.hs
index e6bafdeb..5c1e2b4a 100644
--- a/src/Graphics/UI/Threepenny/Internal/Core.hs
+++ b/src/Graphics/UI/Threepenny/Internal/Core.hs
@@ -70,9 +70,7 @@ module Graphics.UI.Threepenny.Internal.Core
   ,EventData(..)
   ) where
 
-
---------------------------------------------------------------------------------
--- Imports
+
 
 import           Graphics.UI.Threepenny.Internal.Types     as Threepenny
 import           Graphics.UI.Threepenny.Internal.Resources
@@ -101,6 +99,7 @@ import           Snap.Core
 import           Snap.Http.Server              hiding (Config)
 import           Snap.Util.FileServe
 import           System.FilePath
+import qualified Text.JSON as JSON
 import           Text.JSON.Generic
 
 
@@ -161,6 +160,7 @@ withGivenSession token ServerState{..} cont = do
 
 {-----------------------------------------------------------------------------
     Implementation of two-way communication
+    - POST and GET requests
 ------------------------------------------------------------------------------}
 -- | Route the communication between JavaScript and the server
 routeCommunication :: (Session -> IO a) -> ServerState -> Routes
@@ -188,8 +188,8 @@ newSession server info token = do
         , sMutex        = mutex
         , sEvent        = event
         , sEventHandler = handler
-        , sElementIds = ids
-        , sToken = token
+        , sElementIds   = ids
+        , sToken        = token
         , sConnectedState = conState
         , sThreadId    = threadId
         , sClosures    = closures
@@ -197,26 +197,35 @@ newSession server info token = do
         , sServerState = server
         }
 
--- | Initialize the session.
-init :: (Session -> IO void) -> ServerState -> Snap ()
-init sessionThread server = do
-    uri    <- getRequestURI
-    params <- getRequestCookies
-    key    <- io $ modifyMVar (sSessions server) $ \sessions -> do
+-- | Make a new session and add it to the server
+createSession :: (Session -> IO void) -> ServerState -> Snap Session
+createSession worker server = do
+    uri    <- snapRequestURI
+    params <- snapRequestCookies
+    liftIO $ modifyMVar (sSessions server) $ \sessions -> do
         let newKey = maybe 0 (+1) (lastMay (M.keys sessions))
         session <- newSession server (uri,params) newKey
-        _       <- forkIO $ do _ <- sessionThread session; return ()
-        return (M.insert newKey session sessions,newKey)
-    modifyResponse $ setHeader "Set-Token" (fromString (show key))
-    withGivenSession key server poll
-  where
-  getRequestURI = do
+        _       <- forkIO $ void $ worker session
+        return (M.insert newKey session sessions, session)
+
+-- | Respond to initialization request.
+init :: (Session -> IO void) -> ServerState -> Snap ()
+init worker server = do
+    session <- createSession worker server
+    modifyResponse . setHeader "Set-Token" . fromString . show . sToken $ session
+    poll session
+
+snapRequestURI :: Snap URI
+snapRequestURI = do
     uri     <- getInput "info"
     maybe (error ("Unable to parse request URI: " ++ show uri)) return (uri >>= parseURI)
-  getRequestCookies = do
+
+snapRequestCookies :: Snap [(String, String)]
+snapRequestCookies = do
     cookies <- getsRequest rqCookies
     return $ flip map cookies $ \Cookie{..} -> (toString cookieName,toString cookieValue)
-  
+
+
 -- | Respond to poll requests.
 poll :: Session -> Snap ()
 poll Session{..} = do
@@ -240,7 +249,7 @@ signal Session{..} = do
     input <- getInput "signal"
     case input of
       Just signalJson -> do
-        let signal = decode signalJson
+        let signal = JSON.decode signalJson
         case signal of
           Ok signal -> io $ writeChan sSignals signal
           Error err -> error err

From 94402c54a00f74b1e3d39499d00e9ca5caac57e0 Mon Sep 17 00:00:00 2001
From: Heinrich Apfelmus <apfelmus@quantentunnel.de>
Date: Sun, 4 Aug 2013 12:19:18 +0200
Subject: [PATCH 04/41] Reorder driver code to isolate client-server
 communication.

---
 src/Graphics/UI/driver.js | 87 ++++++++++++++++++++-------------------
 1 file changed, 45 insertions(+), 42 deletions(-)

diff --git a/src/Graphics/UI/driver.js b/src/Graphics/UI/driver.js
index d6f1b165..719d6dd2 100644
--- a/src/Graphics/UI/driver.js
+++ b/src/Graphics/UI/driver.js
@@ -46,20 +46,26 @@ $.fn.livechange = function(ms,trigger){
   document.head = document.head || document.getElementsByTagName('head')[0];
 
   ////////////////////////////////////////////////////////////////////////////////
+  // Logging
+  window.do_logging = function(x){
+    $.cookie('tp_log',x.toString());
+  };
+
+  function console_log(){
+    if (tp_enable_log) { window.console.log.apply(window.console,arguments); }
+  }
+
+  ////////////////////////////////////////////////////////////////////////////////
+  // Client-server communication
+  
   // Main entry point
   $(document).ready(function(){
     setTimeout(function(){
       waitForEvents();
     })
   });
-
-  ////////////////////////////////////////////////////////////////////////////////
-  // Running instructions
-
-  window.do_logging = function(x){
-    $.cookie('tp_log',x.toString());
-  };
-    
+  
+  // Poll instruction from the server.
   function waitForEvents(){
     console_log("Polling… (%d signals so far)",signal_count);
     var data = { token: sessionToken };
@@ -101,7 +107,28 @@ $.fn.livechange = function(ms,trigger){
       runMultipleEvents(events);
     });
   }
+  
+  // Send response back to the server.
+  function signal(signal,continuation){
+    signal_count++;
+    console_log('Signal: %s',JSON.stringify(signal));
+    $.ajax({
+      dataType: 'json',
+      url:'signal',
+      data: { token: sessionToken, signal: JSON.stringify(signal) },
+      success: function(){
+        continuation();
+      },
+      error: function(reply){
+        console_log("Error: %o",reply);
+      }
+    });
+  }
 
+
+  ////////////////////////////////////////////////////////////////////////////////
+  // FFI - Execute and reply to commands from the server
+  
   function runEvent(event,continuation){
     console_log("Event: %s",JSON.stringify(event));
     for(var key in event){
@@ -342,32 +369,8 @@ $.fn.livechange = function(ms,trigger){
     }
   }
 
-  function event_delete(event){
-    var id = event.Delete;
-    var el = elidToElement(id);
-    // TODO: Think whether it is correct to remove element ids
-    $(el).detach();
-    deleteElementTable(id);
-  }
-
   ////////////////////////////////////////////////////////////////////////////////
-  // Signalling events
-
-  function signal(signal,continuation){
-    signal_count++;
-    console_log('Signal: %s',JSON.stringify(signal));
-    $.ajax({
-      dataType: 'json',
-      url:'signal',
-      data: { token: sessionToken, signal: JSON.stringify(signal) },
-      success: function(){
-        continuation();
-      },
-      error: function(reply){
-        console_log("Error: %o",reply);
-      }
-    });
-  }
+  // FFI - marshaling
 
   // When the server creates elements, it assigns them a string "elid".  
   // This elidToElement function is used to sync the elids on the server with the 
@@ -420,16 +423,16 @@ $.fn.livechange = function(ms,trigger){
     }
   }
 
-  // A log
-  function console_log(){
-    if (tp_enable_log) {
-      window.console.log.apply(window.console,arguments);
-    }
-  };
-
-
   ////////////////////////////////////////////////////////////////////////////////
-  // Additional functions
+  // FFI - additional primitive functions
+  
+  function event_delete(event){
+    var id = event.Delete;
+    var el = elidToElement(id);
+    // TODO: Think whether it is correct to remove element ids
+    $(el).detach();
+    deleteElementTable(id);
+  }
   
   window.jquery_animate = function(el_id,props,duration,easing,complete){
     var el = elidToElement(JSON.parse(el_id));

From 42deb0561c01a5b31352d9d21c236666b32c5943 Mon Sep 17 00:00:00 2001
From: Heinrich Apfelmus <apfelmus@quantentunnel.de>
Date: Sun, 4 Aug 2013 13:04:44 +0200
Subject: [PATCH 05/41] Refactor driver to parametrize over client-server
 communication.

---
 src/Graphics/UI/driver.js | 129 +++++++++++++++-----------------------
 1 file changed, 51 insertions(+), 78 deletions(-)

diff --git a/src/Graphics/UI/driver.js b/src/Graphics/UI/driver.js
index 719d6dd2..0620fc6c 100644
--- a/src/Graphics/UI/driver.js
+++ b/src/Graphics/UI/driver.js
@@ -57,6 +57,7 @@ $.fn.livechange = function(ms,trigger){
 
   ////////////////////////////////////////////////////////////////////////////////
   // Client-server communication
+  // - GET and POST requests
   
   // Main entry point
   $(document).ready(function(){
@@ -85,8 +86,8 @@ $.fn.livechange = function(ms,trigger){
           console_log('Event list:');
           runMultipleEvents(events);
         } else {
-          runEvent(events,function(){
-            waitForEvents();
+          runEvent(events, signalEvent, function(response){
+            maybeReply(response, waitForEvents);
           });
         }
       },
@@ -103,11 +104,24 @@ $.fn.livechange = function(ms,trigger){
     if(events.length == 0) {
       return waitForEvents();
     }
-    runEvent(events.shift(),function(){
-      runMultipleEvents(events);
+    runEvent(events.shift(), signalEvent, function(response){
+      maybeReply(response, function(){
+        runMultipleEvents(events);
+      });
     });
   }
   
+  // Send an event to the server.
+  function signalEvent(value) {
+    signal({ Event: value}, function (){});
+  }
+  
+  // Send a reply to the server if necessary.
+  function maybeReply(response, continuation) {
+    if (response != undefined) { signal(response, continuation); }
+    else { continuation(); }
+  }
+  
   // Send response back to the server.
   function signal(signal,continuation){
     signal_count++;
@@ -129,7 +143,11 @@ $.fn.livechange = function(ms,trigger){
   ////////////////////////////////////////////////////////////////////////////////
   // FFI - Execute and reply to commands from the server
   
-  function runEvent(event,continuation){
+  function runEvent(event,sendEvent,reply){
+    // reply();      -- Continue without replying to the server.
+    // reply(value); -- Send  value  back to the server.
+    // sendEvent     -- Function that sends a message { Event : value } to the server.
+  
     console_log("Event: %s",JSON.stringify(event));
     for(var key in event){
       switch(key){
@@ -141,7 +159,7 @@ $.fn.livechange = function(ms,trigger){
         // It is not correct to remove the child elements from the el_table
         // because they may still be present on the server side.
         $(el).contents().detach();
-        continuation();
+        reply();
         break;
       }
       case "CallDeferredFunction": {
@@ -152,39 +170,35 @@ $.fn.livechange = function(ms,trigger){
         theFunction.apply(window, params.concat(function(){
           console_log(this);
           var args = Array.prototype.slice.call(arguments,0);
-          signal({
-            Event: closure.concat([args])
-          },function(){
-            // No action.
-          });
+          sendEvent(closure.concat([args]));
         }));
-        continuation();
+        reply();
         break;
       }
       case "RunJSFunction": {
         eval(event.RunJSFunction);
-        continuation();
+        reply();
         break;
       }
       case "CallJSFunction": {
         var result = eval(event.CallJSFunction);
-        signal({FunctionResult : result}, continuation);
+        reply({FunctionResult : result});
         break;
       }
       case "Delete": {
         event_delete(event);
-        continuation();
+        reply();
         break;
       }
       case "Debug": {
         if(window.console)
           console.log("Server debug: %o",event.Debug);
-        continuation();
+        reply();
         break;
       }
       case "Clear": {
         $('body').contents().detach();
-        continuation();
+        reply();
         break;
       }
       case "GetElementsByTagName": {
@@ -196,11 +210,7 @@ $.fn.livechange = function(ms,trigger){
             Element: elementToElid(elements[i])
           });
         }
-        signal({
-          Elements: els
-        },function(){
-          continuation();
-        });
+        reply({ Elements: els });
         break;
       }
       case "GetElementsById": {
@@ -215,11 +225,7 @@ $.fn.livechange = function(ms,trigger){
                 });
             }
         }
-        signal({
-          Elements: els
-        },function(){
-          continuation();
-        });
+        reply({ Elements: els });
         break;
       }
       case "SetStyle": {
@@ -231,7 +237,7 @@ $.fn.livechange = function(ms,trigger){
         for(var i = 0; i < len; i++){
           el.style[style[i][0]] = style[i][1];
         }
-        continuation();
+        reply();
         break;
       }
       case "SetAttr": {
@@ -241,26 +247,18 @@ $.fn.livechange = function(ms,trigger){
         var value = set[2];
         var el    = elidToElement(id);
         $(el).attr(key,value);
-        continuation();
+        reply();
         break;
       }
       case "GetValue": {
         var id = event.GetValue;
         var el = elidToElement(id);
         var value = $(el).val();
-        signal({
-          Value: value
-        },function(){
-          continuation();
-        });
+        reply({ Value: value });
         break;
       }
       case "GetLocation": {
-        signal({
-          Location: window.location.href
-        },function(){
-          continuation();
-        });
+        reply({ Location: window.location.href });
         break;
       }
       case "GetValues": {
@@ -270,34 +268,30 @@ $.fn.livechange = function(ms,trigger){
         for(var i = 0; i < len; i++) {
           values.push($(elidToElement(ids[i])).val());
         }
-        signal({
-          Values: values
-        },function(){
-          continuation();
-        });
+        reply({ Values: values });
         break;
       }
       case "Append": {
         var append = event.Append;
         $(elidToElement(append[0])).append($(elidToElement(append[1])));
-        continuation();
+        reply();
         break;
       }
       case "SetText": {
         var set = event.SetText;
         $(elidToElement(set[0])).text(set[1]);
-        continuation();
+        reply();
         break;
       }
       case "SetTitle": {
         document.title = event.SetTitle;
-        continuation();
+        reply();
         break;
       }
       case "SetHtml": {
         var set = event.SetHtml;
         $(elidToElement(set[0])).html(set[1]);
-        continuation();
+        reply();
         break;
       }
       case "Bind": {
@@ -308,63 +302,42 @@ $.fn.livechange = function(ms,trigger){
         console_log('event type: ' + eventType);
         if(eventType == 'livechange') {
           $(el).livechange(300,function(e){
-            signal({
-              Event: handlerGuid.concat([[$(el).val()]])
-            },function(){
-              // no action
-            });
+            sendEvent( handlerGuid.concat([[$(el).val()]]) );
             return true;
           });
         } else if(eventType == 'sendvalue') {
           $(el).sendvalue(function(x){
-            signal({
-              Event: handlerGuid.concat([[x]])
-            },function(){});
+            sendEvent( handlerGuid.concat([[x]]) );
           });
         } else if(eventType.match('dragstart|dragenter|dragover|dragleave|drag|drop|dragend')) {
           $(el).bind(eventType,function(e){
-            signal({
-              Event: handlerGuid.concat([
+            sendEvent( handlerGuid.concat([
                 e.originalEvent.dataTransfer
                     ?[e.originalEvent.dataTransfer.getData("dragData")]
                     :[]])
-            },function(){
-              // no action
-            });
+              );
             return true;
           });
         } else if(eventType.match('mousemove')) {
           $(el).bind(eventType,function(e){
-            signal({
-              Event: handlerGuid.concat([[e.pageX.toString(), e.pageY.toString()]])
-            },function(){
-              // no action
-            });
+            sendEvent( handlerGuid.concat([[e.pageX.toString(), e.pageY.toString()]]) );
             return true;
           });
         } else if(eventType.match('keydown|keyup')) {
           $(el).bind(eventType,function(e){
-            signal({
-              Event: handlerGuid.concat([[e.keyCode.toString()]])
-            },function(){
-              // no action
-            });
+            sendEvent( handlerGuid.concat([[e.keyCode.toString()]]) );
             return true;
           });
         } else {
           $(el).bind(eventType,function(e){
-            signal({
-              Event: handlerGuid.concat([e.which?[e.which.toString()]:[]])
-            },function(){
-              // no action
-            });
+            sendEvent( handlerGuid.concat([e.which?[e.which.toString()]:[]]) );
             return true;
           });
         }
-        continuation();
+        reply();
         break;
       }
-      default: continuation();
+      default: reply();
       }
     }
   }

From 6933ba48da54316f15bde634a2ae55f31fd63c5e Mon Sep 17 00:00:00 2001
From: Heinrich Apfelmus <apfelmus@quantentunnel.de>
Date: Sun, 4 Aug 2013 14:01:58 +0200
Subject: [PATCH 06/41] Implement WebSocket communication. #23

---
 src/Graphics/UI/Threepenny/Internal/Core.hs | 38 +++++++++++++++++++--
 src/Graphics/UI/driver.js                   | 38 +++++++++++++++++++--
 2 files changed, 71 insertions(+), 5 deletions(-)

diff --git a/src/Graphics/UI/Threepenny/Internal/Core.hs b/src/Graphics/UI/Threepenny/Internal/Core.hs
index 5c1e2b4a..c5c4ba0d 100644
--- a/src/Graphics/UI/Threepenny/Internal/Core.hs
+++ b/src/Graphics/UI/Threepenny/Internal/Core.hs
@@ -93,6 +93,8 @@ import qualified Data.Text                     as Text
 import           Data.Text.Encoding
 import           Data.Time
 import           Network.URI
+import qualified Network.WebSockets as WS
+import qualified Network.WebSockets.Snap as WS
 import           Prelude                       hiding (init)
 import           Safe
 import           Snap.Core
@@ -121,7 +123,8 @@ serve Config{..} worker = do
     let config = setPort tpPort defaultConfig
     httpServe config . route $
         routeResources tpCustomHTML tpStatic server
-        ++ routeCommunication worker server
+        -- ++ routeCommunication worker server
+        ++ routeWebsockets worker server
 
 -- | Kill sessions after at least n seconds of disconnectedness.
 custodian :: Integer -> MVar Sessions -> IO ()
@@ -200,7 +203,8 @@ newSession server info token = do
 -- | Make a new session and add it to the server
 createSession :: (Session -> IO void) -> ServerState -> Snap Session
 createSession worker server = do
-    uri    <- snapRequestURI
+    -- uri    <- snapRequestURI
+    let uri = undefined -- FIXME: No URI for WebSocket requests.
     params <- snapRequestCookies
     liftIO $ modifyMVar (sSessions server) $ \sessions -> do
         let newKey = maybe 0 (+1) (lastMay (M.keys sessions))
@@ -255,6 +259,36 @@ signal Session{..} = do
           Error err -> error err
       Nothing -> error $ "Unable to parse " ++ show input
 
+{-----------------------------------------------------------------------------
+    Implementation of two-way communication
+    - WebSockets
+------------------------------------------------------------------------------}
+-- | Route the communication between JavaScript and the server
+routeWebsockets :: (Session -> IO a) -> ServerState -> Routes
+routeWebsockets worker server =
+    [("websocket", response)]
+    where
+    response = do
+        session <- createSession worker server
+        WS.runWebSocketsSnap $ webSocket session
+
+
+webSocket :: Session -> WS.Request -> WS.WebSockets WS.Hybi10 ()
+webSocket Session{..} req = void $ do
+    WS.acceptRequest req
+
+    -- write data (in another thread)
+    send <- WS.getSink
+    liftIO . forkIO . forever $ do
+        x <- readChan sInstructions 
+        WS.sendSink send . WS.textData . Text.pack . JSON.encode $ x
+
+    -- read data
+    forever $ do
+        input <- WS.receiveData
+        case JSON.decode . Text.unpack $ input of
+            Ok signal -> io $ writeChan sSignals signal
+            Error err -> error err
 
 {-----------------------------------------------------------------------------
     FFI implementation on top of the communication channel
diff --git a/src/Graphics/UI/driver.js b/src/Graphics/UI/driver.js
index 0620fc6c..0d1c5673 100644
--- a/src/Graphics/UI/driver.js
+++ b/src/Graphics/UI/driver.js
@@ -55,16 +55,23 @@ $.fn.livechange = function(ms,trigger){
     if (tp_enable_log) { window.console.log.apply(window.console,arguments); }
   }
 
+  ////////////////////////////////////////////////////////////////////////////////
+  // Main entry point
+  $(document).ready(function(){
+    // initCommunicationHTTP();
+    initCommunicationWebSockets();
+  });
+
   ////////////////////////////////////////////////////////////////////////////////
   // Client-server communication
   // - GET and POST requests
   
-  // Main entry point
-  $(document).ready(function(){
+  // Initialize communication via HTTP requests.
+  function initCommunicationHTTP() {
     setTimeout(function(){
       waitForEvents();
     })
-  });
+  }
   
   // Poll instruction from the server.
   function waitForEvents(){
@@ -138,6 +145,31 @@ $.fn.livechange = function(ms,trigger){
       }
     });
   }
+  
+  ////////////////////////////////////////////////////////////////////////////////
+  // Client-server communication
+  // - WebSockets
+  
+  // Initialize client-server communication via WebSockets.
+  function initCommunicationWebSockets() {
+    var url = 'ws:' + window.location.href.toString().slice(5) + 'websocket';
+    var ws  = new WebSocket(url);
+    
+    var sendEvent = function (e) {
+      ws.send(JSON.stringify({ Event : e}));
+    }
+    var reply     = function (response) {
+      if (response != undefined)
+        ws.send(JSON.stringify(response));
+    }
+    
+    ws.onopen = function (e){
+      ws.onmessage = function (msg) {
+        console_log("WebSocket message: %o",msg);
+        runEvent(JSON.parse(msg.data), sendEvent, reply);        
+      }
+    }
+  }
 
 
   ////////////////////////////////////////////////////////////////////////////////

From 7ae3029c2ede2698b213f2a67716e4a141ac7a06 Mon Sep 17 00:00:00 2001
From: Heinrich Apfelmus <apfelmus@quantentunnel.de>
Date: Sun, 4 Aug 2013 14:54:39 +0200
Subject: [PATCH 07/41] Clean up dependencies.

---
 src/Control/Monad/IO.hs                      |  2 +-
 src/Graphics/UI/Threepenny/Core.hs           |  1 -
 src/Graphics/UI/Threepenny/Internal/Core.hs  | 32 +++++++++++---------
 src/Graphics/UI/Threepenny/Internal/Types.hs |  1 -
 threepenny-gui.cabal                         |  7 +++--
 5 files changed, 22 insertions(+), 21 deletions(-)

diff --git a/src/Control/Monad/IO.hs b/src/Control/Monad/IO.hs
index 0123cb67..26a50113 100644
--- a/src/Control/Monad/IO.hs
+++ b/src/Control/Monad/IO.hs
@@ -2,7 +2,7 @@
 
 module Control.Monad.IO where
 
-import Control.Monad.Trans
+import Control.Monad.IO.Class
 
 io :: MonadIO m => IO a -> m a
 io = liftIO
diff --git a/src/Graphics/UI/Threepenny/Core.hs b/src/Graphics/UI/Threepenny/Core.hs
index c8f3e1a5..51cff999 100644
--- a/src/Graphics/UI/Threepenny/Core.hs
+++ b/src/Graphics/UI/Threepenny/Core.hs
@@ -53,7 +53,6 @@ import Control.Concurrent.MVar
 import Control.Event
 import Control.Monad
 import Control.Monad.IO.Class
-import Control.Monad.Trans.Reader as Reader
 import Network.URI
 import Text.JSON
 
diff --git a/src/Graphics/UI/Threepenny/Internal/Core.hs b/src/Graphics/UI/Threepenny/Internal/Core.hs
index c5c4ba0d..db94ffaf 100644
--- a/src/Graphics/UI/Threepenny/Internal/Core.hs
+++ b/src/Graphics/UI/Threepenny/Internal/Core.hs
@@ -81,8 +81,8 @@ import           Control.Concurrent.Chan.Extra
 import           Control.Concurrent.Delay
 import qualified Control.Exception             as E
 import           Control.Event
-import           Control.Monad.IO
-import           Control.Monad.Reader
+import           Control.Monad
+import           Control.Monad.IO.Class
 import           Data.ByteString               (ByteString)
 import           Data.ByteString.UTF8          (toString,fromString)
 import           Data.Map                      (Map)
@@ -156,7 +156,7 @@ withSession server cont = do
 -- Do something with the session given by its token id.
 withGivenSession :: Integer -> ServerState -> (Session -> Snap a) -> Snap a
 withGivenSession token ServerState{..} cont = do
-    sessions <- io $ withMVar sSessions return
+    sessions <- liftIO $ withMVar sSessions return
     case M.lookup token sessions of
         Nothing -> error $ "Nonexistant token: " ++ show token
         Just session -> cont session
@@ -236,15 +236,17 @@ poll Session{..} = do
     let setDisconnected = do
         now <- getCurrentTime
         modifyMVar_ sConnectedState (const (return (Disconnected now)))
-    io $ modifyMVar_ sConnectedState (const (return Connected))
-    threadId <- io $ myThreadId
-    _ <- io $ forkIO $ do
-        delaySeconds $ 60 * 5 -- Force kill after 5 minutes.
-        killThread threadId
-    instructions <- io $ E.catch (readAvailableChan sInstructions) $ \e -> do
-        when (e == E.ThreadKilled) $ do
-            setDisconnected
-        E.throw e
+    
+    instructions <- liftIO $ do
+        modifyMVar_ sConnectedState (const (return Connected))
+        threadId <- myThreadId
+        forkIO $ do
+            delaySeconds $ 60 * 5 -- Force kill after 5 minutes.
+            killThread threadId
+        E.catch (readAvailableChan sInstructions) $ \e -> do
+            when (e == E.ThreadKilled) $ setDisconnected
+            E.throw e
+    
     writeJson instructions
 
 -- | Handle signals sent from the client.
@@ -255,7 +257,7 @@ signal Session{..} = do
       Just signalJson -> do
         let signal = JSON.decode signalJson
         case signal of
-          Ok signal -> io $ writeChan sSignals signal
+          Ok signal -> liftIO $ writeChan sSignals signal
           Error err -> error err
       Nothing -> error $ "Unable to parse " ++ show input
 
@@ -287,7 +289,7 @@ webSocket Session{..} req = void $ do
     forever $ do
         input <- WS.receiveData
         case JSON.decode . Text.unpack $ input of
-            Ok signal -> io $ writeChan sSignals signal
+            Ok signal -> liftIO $ writeChan sSignals signal
             Error err -> error err
 
 {-----------------------------------------------------------------------------
@@ -398,7 +400,7 @@ routeResources customHTML staticDir server =
 withFilepath :: MVar Filepaths -> (FilePath -> MimeType -> Snap a) -> Snap a
 withFilepath rDict cont = do
     mName    <- getParam "name"
-    (_,dict) <- io $ withMVar rDict return
+    (_,dict) <- liftIO $ withMVar rDict return
     case (\key -> M.lookup key dict) =<< mName of
         Just (path,mimetype) -> cont path mimetype
         Nothing              -> error $ "File not loaded: " ++ show mName
diff --git a/src/Graphics/UI/Threepenny/Internal/Types.hs b/src/Graphics/UI/Threepenny/Internal/Types.hs
index f77387ce..397033f0 100644
--- a/src/Graphics/UI/Threepenny/Internal/Types.hs
+++ b/src/Graphics/UI/Threepenny/Internal/Types.hs
@@ -8,7 +8,6 @@ import Prelude              hiding (init)
 import Control.Applicative
 import Control.Concurrent
 import qualified Control.Event as E
-import Control.Monad.Reader
 import Data.ByteString               (ByteString)
 import Data.Map             (Map)
 import Data.Time
diff --git a/threepenny-gui.cabal b/threepenny-gui.cabal
index 0a67f540..8953fb9c 100644
--- a/threepenny-gui.cabal
+++ b/threepenny-gui.cabal
@@ -1,5 +1,5 @@
 Name:                threepenny-gui
-Version:             0.2.0.0
+Version:             0.3.0.0
 Synopsis:            Small GUI framework that uses the web browser as a display.
 Description:
     Threepenny-GUI is a small GUI framework that uses the web browser as a display.
@@ -50,7 +50,7 @@ Data-files:          src/Graphics/UI/*.js
 
 flag buildExamples
     description: Build example executables.
-    default:     True
+    default:     False
 
 Source-repository head
     type:               git
@@ -83,7 +83,8 @@ Library
   Build-depends:     base                      >= 4     && < 5
                     ,snap-server
                     ,snap-core
-                    ,mtl
+                    ,websockets
+                    ,websockets-snap
                     ,text
                     ,safe
                     ,containers

From bd349d4e036bbd6a08919f2b928afc2184f199e7 Mon Sep 17 00:00:00 2001
From: Heinrich Apfelmus <apfelmus@quantentunnel.de>
Date: Sun, 4 Aug 2013 14:56:36 +0200
Subject: [PATCH 08/41] Remove obsolete 'GetLocation' instruction.

---
 src/Graphics/UI/Threepenny/Internal/Types.hs | 5 +----
 src/Graphics/UI/driver.js                    | 4 ----
 2 files changed, 1 insertion(+), 8 deletions(-)

diff --git a/src/Graphics/UI/Threepenny/Internal/Types.hs b/src/Graphics/UI/Threepenny/Internal/Types.hs
index 397033f0..4e472366 100644
--- a/src/Graphics/UI/Threepenny/Internal/Types.hs
+++ b/src/Graphics/UI/Threepenny/Internal/Types.hs
@@ -110,7 +110,6 @@ data Instruction
   | GetValue ElementId
   | GetValues [ElementId]
   | SetTitle String
-  | GetLocation ()
   | RunJSFunction String
   | CallJSFunction String
   | CallDeferredFunction (Closure,String,[String])
@@ -129,7 +128,6 @@ data Signal
   | Event (String,String,[Maybe String])
   | Value String
   | Values [String]
-  | Location String
   | FunctionCallValues [Maybe String]
   | FunctionResult JSValue
   deriving (Show)
@@ -145,12 +143,11 @@ instance JSON Signal where
           args <- mapM nullable arguments
           return $ Event (cid,typ,args)
         value = Value <$> valFromObj "Value" obj
-        location = Location <$> valFromObj "Location" obj
         values = Values <$> valFromObj "Values" obj
         fcallvalues = do
           FunctionCallValues <$> (valFromObj "FunctionCallValues" obj >>= mapM nullable)
         fresult = FunctionResult <$> valFromObj "FunctionResult" obj
-    init <|> elements <|> event <|> value <|> values <|> location
+    init <|> elements <|> event <|> value <|> values
          <|> fcallvalues <|> fresult
 
 -- | Read a JSValue that may be null.
diff --git a/src/Graphics/UI/driver.js b/src/Graphics/UI/driver.js
index 0d1c5673..bad2e548 100644
--- a/src/Graphics/UI/driver.js
+++ b/src/Graphics/UI/driver.js
@@ -289,10 +289,6 @@ $.fn.livechange = function(ms,trigger){
         reply({ Value: value });
         break;
       }
-      case "GetLocation": {
-        reply({ Location: window.location.href });
-        break;
-      }
       case "GetValues": {
         var ids = event.GetValues;
         var len = ids.length;

From 8b9b1e1a811103c0e1807dbf169f470a0a685f54 Mon Sep 17 00:00:00 2001
From: Heinrich Apfelmus <apfelmus@quantentunnel.de>
Date: Sun, 4 Aug 2013 15:00:37 +0200
Subject: [PATCH 09/41] Remove obsolete 'Begin' and 'End' instructions.

---
 src/Graphics/UI/Threepenny/Internal/Types.hs | 2 --
 1 file changed, 2 deletions(-)

diff --git a/src/Graphics/UI/Threepenny/Internal/Types.hs b/src/Graphics/UI/Threepenny/Internal/Types.hs
index 4e472366..754f23cf 100644
--- a/src/Graphics/UI/Threepenny/Internal/Types.hs
+++ b/src/Graphics/UI/Threepenny/Internal/Types.hs
@@ -95,8 +95,6 @@ data Config = Config
 -- | An instruction that is sent to the client as JSON.
 data Instruction
   = Debug String
-  | Begin ()
-  | End ()
   | SetToken Integer
   | Clear ()
   | GetElementsById [String]

From 0652900970d2a37439ad8763284087c0e9a46e58 Mon Sep 17 00:00:00 2001
From: Heinrich Apfelmus <apfelmus@quantentunnel.de>
Date: Sun, 4 Aug 2013 15:06:03 +0200
Subject: [PATCH 10/41] Replace 'Clear' instruction by FFI call.

---
 src/Graphics/UI/Threepenny/Internal/Core.hs  | 2 +-
 src/Graphics/UI/Threepenny/Internal/Types.hs | 1 -
 src/Graphics/UI/driver.js                    | 5 -----
 3 files changed, 1 insertion(+), 7 deletions(-)

diff --git a/src/Graphics/UI/Threepenny/Internal/Core.hs b/src/Graphics/UI/Threepenny/Internal/Core.hs
index db94ffaf..45cf2da8 100644
--- a/src/Graphics/UI/Threepenny/Internal/Core.hs
+++ b/src/Graphics/UI/Threepenny/Internal/Core.hs
@@ -683,4 +683,4 @@ debug window = run window . Debug
 
 -- | Clear the client's DOM.
 clear :: Window -> IO ()
-clear window = run window $ Clear ()
+clear window = runFunction window $ ffi "$('body').contents().detach()"
diff --git a/src/Graphics/UI/Threepenny/Internal/Types.hs b/src/Graphics/UI/Threepenny/Internal/Types.hs
index 754f23cf..3ce49ad6 100644
--- a/src/Graphics/UI/Threepenny/Internal/Types.hs
+++ b/src/Graphics/UI/Threepenny/Internal/Types.hs
@@ -96,7 +96,6 @@ data Config = Config
 data Instruction
   = Debug String
   | SetToken Integer
-  | Clear ()
   | GetElementsById [String]
   | GetElementsByTagName String
   | SetStyle ElementId [(String,String)]
diff --git a/src/Graphics/UI/driver.js b/src/Graphics/UI/driver.js
index bad2e548..06b7d65e 100644
--- a/src/Graphics/UI/driver.js
+++ b/src/Graphics/UI/driver.js
@@ -228,11 +228,6 @@ $.fn.livechange = function(ms,trigger){
         reply();
         break;
       }
-      case "Clear": {
-        $('body').contents().detach();
-        reply();
-        break;
-      }
       case "GetElementsByTagName": {
         var elements = document.getElementsByTagName(event.GetElementsByTagName);
         var els = [];

From 5bf13396b37aea126a91f1a5c8a6b889ce5dfd33 Mon Sep 17 00:00:00 2001
From: Heinrich Apfelmus <apfelmus@quantentunnel.de>
Date: Sat, 10 Aug 2013 17:07:26 +0200
Subject: [PATCH 11/41] Make 'Element' an instance of 'Typeable'.

---
 src/Graphics/UI/Threepenny/Core.hs | 4 +++-
 1 file changed, 3 insertions(+), 1 deletion(-)

diff --git a/src/Graphics/UI/Threepenny/Core.hs b/src/Graphics/UI/Threepenny/Core.hs
index 51cff999..bf2f0615 100644
--- a/src/Graphics/UI/Threepenny/Core.hs
+++ b/src/Graphics/UI/Threepenny/Core.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE DeriveDataTypeable #-}
 module Graphics.UI.Threepenny.Core (
     -- * Guide
     -- $guide
@@ -45,6 +46,7 @@ module Graphics.UI.Threepenny.Core (
     
     ) where
 
+import Data.Dynamic
 import Data.IORef
 import Data.Maybe (listToMaybe)
 import Data.Functor
@@ -145,7 +147,7 @@ cookies = mkReadAttr Core.getRequestCookies
 type Value = String
 
 -- | Reference to an element in the DOM of the client window.
-newtype Element = Element (MVar Elem)
+newtype Element = Element (MVar Elem) deriving (Typeable)
 data    Elem
     = Alive Core.Element                       -- element exists in a window
     | Limbo Value (Window -> IO Core.Element)  -- still needs to be created

From f36fa0b06ce7e106973190bc7f3068e37350a331 Mon Sep 17 00:00:00 2001
From: Heinrich Apfelmus <apfelmus@quantentunnel.de>
Date: Sat, 10 Aug 2013 17:25:58 +0200
Subject: [PATCH 12/41] Remove obsolete 'Init' signal.

---
 src/Graphics/UI/Threepenny/Internal/Types.hs | 11 ++++-------
 1 file changed, 4 insertions(+), 7 deletions(-)

diff --git a/src/Graphics/UI/Threepenny/Internal/Types.hs b/src/Graphics/UI/Threepenny/Internal/Types.hs
index 3ce49ad6..701ad120 100644
--- a/src/Graphics/UI/Threepenny/Internal/Types.hs
+++ b/src/Graphics/UI/Threepenny/Internal/Types.hs
@@ -120,21 +120,19 @@ instance JSON Instruction where
 
 -- | A signal (mostly events) that are sent from the client to the server.
 data Signal
-  = Init ()
-  | Elements [ElementId]
+  = Elements [ElementId]
   | Event (String,String,[Maybe String])
   | Value String
   | Values [String]
   | FunctionCallValues [Maybe String]
   | FunctionResult JSValue
-  deriving (Show)
+  deriving (Typeable,Show)
 
 instance JSON Signal where
   showJSON _ = error "JSON.Signal.showJSON: No method implemented."
   readJSON obj = do
     obj <- readJSON obj
-    let init = Init <$> valFromObj "Init" obj
-        elements = Elements <$> valFromObj "Elements" obj
+    let elements = Elements <$> valFromObj "Elements" obj
         event = do
           (cid,typ,arguments) <- valFromObj "Event" obj
           args <- mapM nullable arguments
@@ -144,8 +142,7 @@ instance JSON Signal where
         fcallvalues = do
           FunctionCallValues <$> (valFromObj "FunctionCallValues" obj >>= mapM nullable)
         fresult = FunctionResult <$> valFromObj "FunctionResult" obj
-    init <|> elements <|> event <|> value <|> values
-         <|> fcallvalues <|> fresult
+    elements <|> event <|> value <|> values <|> fcallvalues <|> fresult
 
 -- | Read a JSValue that may be null.
 nullable :: JSON a => JSValue -> Result (Maybe a)

From e710363f0fa89c101b0284c2c597e63e941b528e Mon Sep 17 00:00:00 2001
From: Heinrich Apfelmus <apfelmus@quantentunnel.de>
Date: Sat, 10 Aug 2013 17:27:38 +0200
Subject: [PATCH 13/41] Add ping/pong mechanism to client and server. This
 fixes a problem with connections being closed on the client side due to some
 stupid interpretation of inactivity. #23

---
 src/Graphics/UI/Threepenny/Internal/Core.hs | 24 +++++++-----
 src/Graphics/UI/dev-notes-websockets.md     | 43 +++++++++++++++++++++
 src/Graphics/UI/driver.js                   | 18 ++++++++-
 3 files changed, 74 insertions(+), 11 deletions(-)
 create mode 100644 src/Graphics/UI/dev-notes-websockets.md

diff --git a/src/Graphics/UI/Threepenny/Internal/Core.hs b/src/Graphics/UI/Threepenny/Internal/Core.hs
index 45cf2da8..685bf08f 100644
--- a/src/Graphics/UI/Threepenny/Internal/Core.hs
+++ b/src/Graphics/UI/Threepenny/Internal/Core.hs
@@ -138,11 +138,13 @@ custodian seconds sessions = forever $ do
         Disconnected time -> do
           now <- getCurrentTime
           let dcSeconds = diffUTCTime now time
+          -- session is disconnected for more than  seconds
           if (dcSeconds > fromIntegral seconds)
              then do killThread sThreadId
                      return (Just key)
              else return Nothing
-            
+    
+    -- remove killed sessions from the map
     return (M.filterWithKey (\k _ -> not (k `elem` killed)) sessions)
 
 -- Run a snap action with the given session.
@@ -158,7 +160,7 @@ withGivenSession :: Integer -> ServerState -> (Session -> Snap a) -> Snap a
 withGivenSession token ServerState{..} cont = do
     sessions <- liftIO $ withMVar sSessions return
     case M.lookup token sessions of
-        Nothing -> error $ "Nonexistant token: " ++ show token
+        Nothing      -> error $ "Nonexistant token: " ++ show token
         Just session -> cont session
 
 {-----------------------------------------------------------------------------
@@ -244,6 +246,7 @@ poll Session{..} = do
             delaySeconds $ 60 * 5 -- Force kill after 5 minutes.
             killThread threadId
         E.catch (readAvailableChan sInstructions) $ \e -> do
+            -- no instructions available after some time
             when (e == E.ThreadKilled) $ setDisconnected
             E.throw e
     
@@ -274,23 +277,26 @@ routeWebsockets worker server =
         session <- createSession worker server
         WS.runWebSocketsSnap $ webSocket session
 
-
-webSocket :: Session -> WS.Request -> WS.WebSockets WS.Hybi10 ()
+webSocket :: Session -> WS.Request -> WS.WebSockets WS.Hybi00 ()
 webSocket Session{..} req = void $ do
     WS.acceptRequest req
+    -- websockets are always connected, don't let the custodian kill you.
+    liftIO $ modifyMVar_ sConnectedState (const (return Connected))
 
     -- write data (in another thread)
     send <- WS.getSink
     liftIO . forkIO . forever $ do
-        x <- readChan sInstructions 
+        x <- readChan sInstructions
         WS.sendSink send . WS.textData . Text.pack . JSON.encode $ x
 
     -- read data
     forever $ do
         input <- WS.receiveData
-        case JSON.decode . Text.unpack $ input of
-            Ok signal -> liftIO $ writeChan sSignals signal
-            Error err -> error err
+        if input == "ping"
+            then liftIO . WS.sendSink send . WS.textData . Text.pack $ "pong"
+            else case JSON.decode . Text.unpack $ input of
+                Ok signal -> liftIO $ writeChan sSignals signal
+                Error err -> error err
 
 {-----------------------------------------------------------------------------
     FFI implementation on top of the communication channel
@@ -454,7 +460,7 @@ handleEvent window@(Session{..}) = do
     case signal of
         Threepenny.Event (elid,eventType,params) -> do
             sEventHandler ((elid,eventType), EventData params)
-        _ -> return ()
+        _       -> return ()
 
 -- Get the latest signal sent from the client.
 getSignal :: Window -> IO Signal
diff --git a/src/Graphics/UI/dev-notes-websockets.md b/src/Graphics/UI/dev-notes-websockets.md
new file mode 100644
index 00000000..2485434e
--- /dev/null
+++ b/src/Graphics/UI/dev-notes-websockets.md
@@ -0,0 +1,43 @@
+Development Notes on Websockets
+===============================
+
+Turns out that WebSocket implementations in browsers are horrible.
+
+Issues:
+
+1. WebSocket objects get closed unexpectedly on the client.
+
+    To the server, it looks like the connection is still alive,
+    it does not throw a  ConnectionClosed  exception.
+    In fact, the connection may still be alive, see 3.
+
+    The JS object on the client does receive an `onclose` message.
+    
+    The JS object is closed even when the client is sending data
+    periodically!
+    
+    Fortunately, the JS object is *not* closed when the server
+    sends data periodically.
+
+2. WebSocket connections can persist over a browser reload. WTF?
+
+    Opening a new WebSocket will instead reuse the old socket,
+    and the server will send data to both connections (which are just one).
+    
+    In fact, if the read end on the client closes and the server
+    throws a `ConnectionClosed` exception, the write end may still be open.
+
+
+Facts:
+
+* When the  websocket.close();  function is called,
+  the server will throw a proper `ConnectionClosed` exception.
+
+* When the browser window is closed or reloaded,
+  the server will also throw a `ConncetionClosed` exception.
+
+
+Support:
+
+* Safari `5.1.9` only supports the `Hybi00` protocol.
+
diff --git a/src/Graphics/UI/driver.js b/src/Graphics/UI/driver.js
index 06b7d65e..2050f0d4 100644
--- a/src/Graphics/UI/driver.js
+++ b/src/Graphics/UI/driver.js
@@ -162,11 +162,25 @@ $.fn.livechange = function(ms,trigger){
       if (response != undefined)
         ws.send(JSON.stringify(response));
     }
+    // Send ping message in regular intervals.
+    // We expect pong messages in return to keep the connection alive.
+    function ping(){
+      ws.send("ping");
+      window.setTimeout(ping,2000);
+    }
     
     ws.onopen = function (e){
+      ping();
       ws.onmessage = function (msg) {
-        console_log("WebSocket message: %o",msg);
-        runEvent(JSON.parse(msg.data), sendEvent, reply);        
+        // console_log("WebSocket message: %o",msg);
+        if (msg.data != "pong")
+          { runEvent(JSON.parse(msg.data), sendEvent, reply); }
+      }
+      ws.onclose = function (e) {
+        console_log("WebSocket closed: %o", e);
+      }
+      ws.onerror = function (e) {
+        console_log("WebSocket error: %o", e);
       }
     }
   }

From 01e02cfb0b2a01c94cb4438a760f4bce339836d7 Mon Sep 17 00:00:00 2001
From: Heinrich Apfelmus <apfelmus@quantentunnel.de>
Date: Sat, 10 Aug 2013 17:43:22 +0200
Subject: [PATCH 14/41] Fix 'DrumMachine' example: stop audio sample before
 playing it again. Thanks to the new WebSockets implementation, the drum
 machine can now keep a steady beat!

---
 src/DrumMachine.hs                          |  4 +++-
 src/Graphics/UI/Threepenny/Core.hs          | 11 +++++++++--
 src/Graphics/UI/Threepenny/Internal/Core.hs | 11 -----------
 src/Graphics/UI/driver.js                   |  5 +++++
 4 files changed, 17 insertions(+), 14 deletions(-)

diff --git a/src/DrumMachine.hs b/src/DrumMachine.hs
index 8c935aff..e3cfe777 100644
--- a/src/DrumMachine.hs
+++ b/src/DrumMachine.hs
@@ -97,7 +97,9 @@ mkInstrument window name = do
     let
         play box = do
             checked <- get UI.checked box
-            when checked $ audioPlay elAudio
+            when checked $ do
+                audioStop elAudio -- just in case the sound is already playing
+                audioPlay elAudio
         beats    = map play . concat $ elCheckboxes
         elGroups = [UI.span #. "bar" #+ map element bar | bar <- elCheckboxes]
     
diff --git a/src/Graphics/UI/Threepenny/Core.hs b/src/Graphics/UI/Threepenny/Core.hs
index bf2f0615..53f218f7 100644
--- a/src/Graphics/UI/Threepenny/Core.hs
+++ b/src/Graphics/UI/Threepenny/Core.hs
@@ -42,7 +42,8 @@ module Graphics.UI.Threepenny.Core (
     callDeferredFunction, atomic,
     
     -- * Internal and oddball functions
-    updateElement, manifestElement, audioPlay, fromProp,
+    updateElement, manifestElement, fromProp,
+    audioPlay, audioStop,
     
     ) where
 
@@ -320,7 +321,13 @@ getElementsById window name =
 {-----------------------------------------------------------------------------
     Oddball
 ------------------------------------------------------------------------------}
-audioPlay = updateElement Core.audioPlay
+-- | Invoke the JavaScript expression @audioElement.play();@.
+audioPlay = updateElement $ \el -> Core.runFunction (Core.getWindow el) $
+    ffi "%1.play()" el
+
+-- | Invoke the JavaScript expression @audioElement.stop();@.
+audioStop = updateElement $ \el -> Core.runFunction (Core.getWindow el) $
+    ffi "prim_audio_stop(%1)" el
 
 -- Turn a jQuery property @.prop()@ into an attribute.
 fromProp :: String -> (JSValue -> a) -> (a -> JSValue) -> Attr Element a
diff --git a/src/Graphics/UI/Threepenny/Internal/Core.hs b/src/Graphics/UI/Threepenny/Internal/Core.hs
index 685bf08f..2edd9d4b 100644
--- a/src/Graphics/UI/Threepenny/Internal/Core.hs
+++ b/src/Graphics/UI/Threepenny/Internal/Core.hs
@@ -60,9 +60,6 @@ module Graphics.UI.Threepenny.Internal.Core
   ,ToJS, FFI, ffi, JSFunction
   ,runFunction, callFunction
   
-  -- * Oddball
-  ,audioPlay
-  
   -- * Types
   ,Window
   ,Element
@@ -574,14 +571,6 @@ appendElementTo (Element parent session) e@(Element child _) =
     --       Implement transfer of elements across browser windows
     run session $ Append parent child
 
-
-{-----------------------------------------------------------------------------
-    Oddball
-------------------------------------------------------------------------------}
--- | Invoke the JavaScript expression @audioElement.play();@.
-audioPlay :: Element -> IO ()
-audioPlay (Element el session) = runFunction session $ ffi "%1.play();" el
-
 {-----------------------------------------------------------------------------
     Querying the DOM
 ------------------------------------------------------------------------------}
diff --git a/src/Graphics/UI/driver.js b/src/Graphics/UI/driver.js
index 2050f0d4..448a9059 100644
--- a/src/Graphics/UI/driver.js
+++ b/src/Graphics/UI/driver.js
@@ -456,6 +456,11 @@ $.fn.livechange = function(ms,trigger){
     $(el).scrollTop(el.scrollHeight);
   };
 
+  function prim_audio_stop(audio){
+    audio.pause();
+    audio.currentTime = 0;
+  }
+
   // see http://stackoverflow.com/a/9722502/403805
   CanvasRenderingContext2D.prototype.clear = 
     CanvasRenderingContext2D.prototype.clear || function (preserveTransform) {

From c12c24c1e29690aad01d91f4334665c29a66157b Mon Sep 17 00:00:00 2001
From: Heinrich Apfelmus <apfelmus@quantentunnel.de>
Date: Sat, 10 Aug 2013 23:01:56 +0200
Subject: [PATCH 15/41] Refactor 'Timer' internals so they don't depend on STM
 anymore. Small adjustment to 'DrumMachine'.

---
 src/DrumMachine.hs                  |  2 +-
 src/Graphics/UI/Threepenny/Timer.hs | 47 ++++++++++++++++++-----------
 2 files changed, 30 insertions(+), 19 deletions(-)

diff --git a/src/DrumMachine.hs b/src/DrumMachine.hs
index e3cfe777..f4bf0bac 100644
--- a/src/DrumMachine.hs
+++ b/src/DrumMachine.hs
@@ -69,7 +69,7 @@ setup w = void $ do
         sequence_ $ map (!! beat) kit
     
     -- allow user to set BPM
-    on (domEvent "livechange") elBpm $ const $ void $ do
+    on UI.keydown elBpm $ \keycode -> when (keycode == 13) $ void $ do
         bpm <- read <$> get value elBpm
         return timer # set UI.interval (bpm2ms bpm)
     
diff --git a/src/Graphics/UI/Threepenny/Timer.hs b/src/Graphics/UI/Threepenny/Timer.hs
index afd97cba..db735e21 100644
--- a/src/Graphics/UI/Threepenny/Timer.hs
+++ b/src/Graphics/UI/Threepenny/Timer.hs
@@ -1,15 +1,18 @@
-{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE RecordWildCards, DeriveDataTypeable #-}
 
 module Graphics.UI.Threepenny.Timer (
     -- * Synopsis
     -- | Implementation of a simple timer which runs on the server-side.
+    --
+    -- NOTE: The timer may be rather wobbly unless you compile
+    -- with the @-threaded@ option.
     
     -- * Documentation
     Timer, timer,
     interval, running, tick, start, stop,
     ) where
 
-
+import Data.Typeable
 import Control.Monad (when, forever, void)
 import Control.Event
 import Control.Concurrent
@@ -19,37 +22,42 @@ import Graphics.UI.Threepenny.Core
 
 
 data Timer = Timer
-    { tRunning  :: TVar Bool
-    , tInterval :: TVar Int      -- in ms
+    { tRunning  :: GetSet Bool Bool
+    , tInterval :: GetSet Int Int   -- in ms
     , tTick     :: Event ()
-    }
+    } deriving (Typeable)
 
 -- | Create a new timer
 timer :: IO Timer
 timer = do
-    tRunning      <- newTVarIO False
-    tInterval     <- newTVarIO 1000
+    tvRunning     <- newTVarIO False
+    tvInterval    <- newTVarIO 1000
     (tTick, fire) <- newEvent
     
     forkIO $ forever $ do
-        wait <- atomically $ do
-            b <- readTVar tRunning
+        atomically $ do
+            b <- readTVar tvRunning
             when (not b) retry
-            readTVar tInterval
-        threadDelay (wait * 1000)
+        wait <- atomically $ readTVar tvInterval
         fire ()
-        
+        threadDelay (wait * 1000)
+    
+    let tRunning  = fromTVar tvRunning
+        tInterval = fromTVar tvInterval 
+    
     return $ Timer {..}
 
+-- | Timer event.
+tick :: Timer -> Event ()
 tick = tTick
 
 -- | Timer interval in milliseconds.
 interval :: Attr Timer Int
-interval = fromTVar tInterval
+interval = fromGetSet tInterval
 
 -- | Whether the timer is running or not.
 running :: Attr Timer Bool
-running = fromTVar tRunning
+running = fromGetSet tRunning
 
 -- | Start the timer.
 start :: Timer -> IO ()
@@ -59,10 +67,13 @@ start = set' running True
 stop :: Timer -> IO ()
 stop = set' running False
 
-fromTVar :: (x -> TVar a) -> Attr x a
-fromTVar f = mkReadWriteAttr
-    (atomically . readTVar . f)
-    (\i x -> atomically $ writeTVar (f x) i)
+fromTVar :: TVar a -> GetSet a a
+fromTVar var = (atomically $ readTVar var, atomically . writeTVar var)
+
+type GetSet i o = (IO o, i -> IO ())
+
+fromGetSet :: (x -> GetSet i o) -> ReadWriteAttr x i o
+fromGetSet f = mkReadWriteAttr (fst . f) (\i x -> snd (f x) i)
 
 
 {-----------------------------------------------------------------------------

From 5252155d75524e64667c1816937c7abc43153e30 Mon Sep 17 00:00:00 2001
From: Heinrich Apfelmus <apfelmus@quantentunnel.de>
Date: Sun, 11 Aug 2013 15:47:05 +0200
Subject: [PATCH 16/41] Fix: server should not send on WebSocket once a client
 has closed the conncetion. Add a 'disconnect' event that signals when a
 browser window has been closed. #37

---
 src/Chat.hs                                  | 46 ++++++++------
 src/Graphics/UI/Threepenny/Core.hs           | 14 ++++-
 src/Graphics/UI/Threepenny/Internal/Core.hs  | 64 ++++++++++++--------
 src/Graphics/UI/Threepenny/Internal/Types.hs |  8 ++-
 src/Graphics/UI/driver.js                    |  5 ++
 5 files changed, 87 insertions(+), 50 deletions(-)

diff --git a/src/Chat.hs b/src/Chat.hs
index de145094..906304d5 100644
--- a/src/Chat.hs
+++ b/src/Chat.hs
@@ -8,6 +8,7 @@ import Control.Monad
 import Data.Functor
 import Data.List.Extra
 import Data.Time
+import Data.IORef
 import Prelude hiding (catch)
 
 import Control.Monad.Trans.Reader as Reader
@@ -39,15 +40,15 @@ main = do
 type Message = (UTCTime, String, String)
 
 setup :: Chan Message -> Window -> IO ()
-setup globalMsgs w = do
+setup globalMsgs window = do
     msgs <- Chan.dupChan globalMsgs
 
-    return w # set title "Chat"
+    return window # set title "Chat"
     
-    (nick, nickname) <- mkNickname
-    messageArea      <- mkMessageArea msgs nick
+    (nickRef, nickname) <- mkNickname
+    messageArea         <- mkMessageArea msgs nickRef
 
-    getBody w #+
+    getBody window #+
         [ UI.div #. "header"   #+ [string "Threepenny Chat"]
         , UI.div #. "gradient"
         , viewSource
@@ -55,11 +56,15 @@ setup globalMsgs w = do
         , element messageArea
         ]
     
-    void $ forkIO $ receiveMessages w msgs messageArea
+    messageReceiver <- forkIO $ receiveMessages window msgs messageArea
+
+    on UI.disconnect window $ const $ do
+        putStrLn "Disconnected!"
+        killThread messageReceiver
+        now   <- getCurrentTime
+        nick  <- readIORef nickRef
+        Chan.writeChan msgs (now,nick,"( left the conversation )")
 
---    io $ catch (runTP session handleEvents)
---             (\e -> do killThread messageReceiver
---                       throw (e :: SomeException))
 
 receiveMessages w msgs messageArea = do
     messages <- Chan.getChanContents msgs
@@ -68,14 +73,14 @@ receiveMessages w msgs messageArea = do
           element messageArea #+ [mkMessage msg]
           UI.scrollToBottom messageArea
 
-mkMessageArea :: Chan Message -> Element -> IO Element
+mkMessageArea :: Chan Message -> IORef String -> IO Element
 mkMessageArea msgs nickname = do
     input <- UI.textarea #. "send-textarea"
     
     on UI.sendValue input $ (. trim) $ \content -> do
         when (not (null content)) $ do
             now  <- getCurrentTime
-            nick <- trim <$> get value nickname
+            nick <- readIORef nickname
             element input # set value ""
             when (not (null nick)) $
                 Chan.writeChan msgs (now,nick,content)
@@ -83,15 +88,18 @@ mkMessageArea msgs nickname = do
     UI.div #. "message-area" #+ [UI.div #. "send-area" #+ [element input]]
 
 
-mkNickname :: IO (Element, Element)
+mkNickname :: IO (IORef String, Element)
 mkNickname = do
-    i  <- UI.input #. "name-input"
-    el <- UI.div   #. "name-area"  #+
-        [ UI.span  #. "name-label" #+ [string "Your name "]
-        , element i
-        ]
-    UI.setFocus i
-    return (i,el)
+    input  <- UI.input #. "name-input"
+    el     <- UI.div   #. "name-area"  #+
+                [ UI.span  #. "name-label" #+ [string "Your name "]
+                , element input
+                ]
+    UI.setFocus input
+    
+    nick <- newIORef ""
+    on UI.keyup input $ \_ -> writeIORef nick . trim =<< get value input
+    return (nick,el)
 
 mkMessage :: Message -> IO Element
 mkMessage (timestamp, nick, content) =
diff --git a/src/Graphics/UI/Threepenny/Core.hs b/src/Graphics/UI/Threepenny/Core.hs
index 53f218f7..dad2bb68 100644
--- a/src/Graphics/UI/Threepenny/Core.hs
+++ b/src/Graphics/UI/Threepenny/Core.hs
@@ -26,7 +26,7 @@ module Graphics.UI.Threepenny.Core (
     
     -- * Events
     -- | For a list of predefined events, see "Graphics.UI.Threepenny.Events".
-    EventData(..), domEvent, on,
+    EventData(..), domEvent, on, disconnect,
     module Control.Event,
     
     -- * Attributes
@@ -115,8 +115,7 @@ startGUI
     :: Config               -- ^ Server configuration.
     -> (Window -> IO ())    -- ^ Action to run whenever a client browser connects.
     -> IO ()
-startGUI config handler =
-    Core.serve config $ \w -> handler w >> Core.handleEvents w
+startGUI config handler = Core.serve config handler
 
 
 -- | Make a local file available as a relative URI.
@@ -410,6 +409,15 @@ domEvent name element = Control.Event.Event $ \handler -> do
     register'
     return unregister'
 
+
+-- | Event that occurs whenever the client has disconnected,
+-- be it by closing the browser window or by exception.
+--
+-- Note: DOM Elements in the browser window that has been closed
+-- can no longer be manipulated.
+disconnect :: Window -> Event ()
+disconnect = Core.disconnect
+
 -- | Convenience function to register 'Event's for 'Element's.
 --
 -- Example usage.
diff --git a/src/Graphics/UI/Threepenny/Internal/Core.hs b/src/Graphics/UI/Threepenny/Internal/Core.hs
index 2edd9d4b..a48444c0 100644
--- a/src/Graphics/UI/Threepenny/Internal/Core.hs
+++ b/src/Graphics/UI/Threepenny/Internal/Core.hs
@@ -1,5 +1,5 @@
 {-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedStrings, PackageImports #-}
 {-# OPTIONS -fno-warn-name-shadowing #-}
 
 module Graphics.UI.Threepenny.Internal.Core
@@ -15,8 +15,7 @@ module Graphics.UI.Threepenny.Internal.Core
   -- * Event handling
   -- $eventhandling
   ,bind
-  ,handleEvent
-  ,handleEvents
+  ,disconnect
   ,module Control.Event
   
   -- * Setting attributes
@@ -76,10 +75,11 @@ import           Control.Applicative
 import           Control.Concurrent
 import           Control.Concurrent.Chan.Extra
 import           Control.Concurrent.Delay
-import qualified Control.Exception             as E
+import qualified Control.Exception
 import           Control.Event
 import           Control.Monad
 import           Control.Monad.IO.Class
+import qualified "MonadCatchIO-transformers" Control.Monad.CatchIO as E
 import           Data.ByteString               (ByteString)
 import           Data.ByteString.UTF8          (toString,fromString)
 import           Data.Map                      (Map)
@@ -90,8 +90,9 @@ import qualified Data.Text                     as Text
 import           Data.Text.Encoding
 import           Data.Time
 import           Network.URI
-import qualified Network.WebSockets as WS
-import qualified Network.WebSockets.Snap as WS
+import qualified Network.WebSockets            as WS
+import qualified Network.WebSockets.Snap       as WS
+import qualified Data.Attoparsec.Enumerator    as Atto
 import           Prelude                       hiding (init)
 import           Safe
 import           Snap.Core
@@ -208,7 +209,7 @@ createSession worker server = do
     liftIO $ modifyMVar (sSessions server) $ \sessions -> do
         let newKey = maybe 0 (+1) (lastMay (M.keys sessions))
         session <- newSession server (uri,params) newKey
-        _       <- forkIO $ void $ worker session
+        _       <- forkIO $ void $ worker session >> handleEvents session
         return (M.insert newKey session sessions, session)
 
 -- | Respond to initialization request.
@@ -244,7 +245,7 @@ poll Session{..} = do
             killThread threadId
         E.catch (readAvailableChan sInstructions) $ \e -> do
             -- no instructions available after some time
-            when (e == E.ThreadKilled) $ setDisconnected
+            when (e == Control.Exception.ThreadKilled) $ setDisconnected
             E.throw e
     
     writeJson instructions
@@ -272,7 +273,9 @@ routeWebsockets worker server =
     where
     response = do
         session <- createSession worker server
-        WS.runWebSocketsSnap $ webSocket session
+        WS.runWebSocketsSnap (webSocket session)
+        error "Threepenny.Internal.Core: runWebSocketsSnap should never return."
+
 
 webSocket :: Session -> WS.Request -> WS.WebSockets WS.Hybi00 ()
 webSocket Session{..} req = void $ do
@@ -281,19 +284,25 @@ webSocket Session{..} req = void $ do
     liftIO $ modifyMVar_ sConnectedState (const (return Connected))
 
     -- write data (in another thread)
-    send <- WS.getSink
-    liftIO . forkIO . forever $ do
+    send     <- WS.getSink
+    sendData <- liftIO . forkIO . forever $ do
         x <- readChan sInstructions
         WS.sendSink send . WS.textData . Text.pack . JSON.encode $ x
 
     -- read data
-    forever $ do
-        input <- WS.receiveData
-        if input == "ping"
-            then liftIO . WS.sendSink send . WS.textData . Text.pack $ "pong"
-            else case JSON.decode . Text.unpack $ input of
-                Ok signal -> liftIO $ writeChan sSignals signal
-                Error err -> error err
+    let readData = do
+            input <- WS.receiveData
+            case input of
+                "ping" -> liftIO . WS.sendSink send . WS.textData . Text.pack $ "pong"
+                "quit" -> WS.throwWsError WS.ConnectionClosed
+                input  -> case JSON.decode . Text.unpack $ input of
+                    Ok signal -> liftIO $ writeChan sSignals signal
+                    Error err -> WS.throwWsError . WS.ParseError $ Atto.ParseError [] err
+    
+    forever readData `WS.catchWsError`
+        \_ -> liftIO $ do
+            killThread sendData             -- kill sending thread when done
+            writeChan sSignals $ Quit ()    -- signal  Quit  event
 
 {-----------------------------------------------------------------------------
     FFI implementation on top of the communication channel
@@ -448,17 +457,18 @@ loadDirectory Session{..} path = do
 
 -- | Handle events signalled from the client.
 handleEvents :: Window -> IO ()
-handleEvents window = forever $ handleEvent window
-
--- | Handle one event.
-handleEvent :: Window -> IO ()
-handleEvent window@(Session{..}) = do
+handleEvents window@(Session{..}) = do
     signal <- getSignal window
     case signal of
         Threepenny.Event (elid,eventType,params) -> do
             sEventHandler ((elid,eventType), EventData params)
-        _       -> return ()
-
+            handleEvents window
+        Quit () -> do
+            sEventHandler (("","quit"), EventData [])
+            -- do not continue handling events
+        _       -> do
+            handleEvents window
+            
 -- Get the latest signal sent from the client.
 getSignal :: Window -> IO Signal
 getSignal (Session{..}) = readChan sSignals
@@ -479,6 +489,10 @@ bind eventType (Element el@(ElementId elid) session) =
         run session $ Bind eventType el (Closure key)
         return unregister
 
+-- | Event that occurs when the client has disconnected.
+disconnect :: Window -> Event ()
+disconnect window = () <$ sEvent window ("","quit")
+
 -- Make a uniquely numbered event handler.
 newClosure :: Window -> String -> String -> ([Maybe String] -> IO ()) -> IO Closure
 newClosure window@(Session{..}) eventType elid thunk = do
diff --git a/src/Graphics/UI/Threepenny/Internal/Types.hs b/src/Graphics/UI/Threepenny/Internal/Types.hs
index 701ad120..0816d425 100644
--- a/src/Graphics/UI/Threepenny/Internal/Types.hs
+++ b/src/Graphics/UI/Threepenny/Internal/Types.hs
@@ -120,7 +120,8 @@ instance JSON Instruction where
 
 -- | A signal (mostly events) that are sent from the client to the server.
 data Signal
-  = Elements [ElementId]
+  = Quit ()
+  | Elements [ElementId]
   | Event (String,String,[Maybe String])
   | Value String
   | Values [String]
@@ -132,7 +133,8 @@ instance JSON Signal where
   showJSON _ = error "JSON.Signal.showJSON: No method implemented."
   readJSON obj = do
     obj <- readJSON obj
-    let elements = Elements <$> valFromObj "Elements" obj
+    let quit     = Quit <$> valFromObj "Quit" obj
+        elements = Elements <$> valFromObj "Elements" obj
         event = do
           (cid,typ,arguments) <- valFromObj "Event" obj
           args <- mapM nullable arguments
@@ -142,7 +144,7 @@ instance JSON Signal where
         fcallvalues = do
           FunctionCallValues <$> (valFromObj "FunctionCallValues" obj >>= mapM nullable)
         fresult = FunctionResult <$> valFromObj "FunctionResult" obj
-    elements <|> event <|> value <|> values <|> fcallvalues <|> fresult
+    quit <|> elements <|> event <|> value <|> values <|> fcallvalues <|> fresult
 
 -- | Read a JSValue that may be null.
 nullable :: JSON a => JSValue -> Result (Maybe a)
diff --git a/src/Graphics/UI/driver.js b/src/Graphics/UI/driver.js
index 448a9059..680e3f21 100644
--- a/src/Graphics/UI/driver.js
+++ b/src/Graphics/UI/driver.js
@@ -155,6 +155,11 @@ $.fn.livechange = function(ms,trigger){
     var url = 'ws:' + window.location.href.toString().slice(5) + 'websocket';
     var ws  = new WebSocket(url);
     
+    $(window).unload( function () {
+      // Make sure that the WebSocket is closed when the browser window is closed.
+      ws.close();
+    });
+    
     var sendEvent = function (e) {
       ws.send(JSON.stringify({ Event : e}));
     }

From 541bed95a78bfbce4526102df2ddf35e1e60b7b5 Mon Sep 17 00:00:00 2001
From: Heinrich Apfelmus <apfelmus@quantentunnel.de>
Date: Sun, 11 Aug 2013 15:57:14 +0200
Subject: [PATCH 17/41] Minor updates to Readme.

---
 README.md | 16 ++++++++++------
 1 file changed, 10 insertions(+), 6 deletions(-)

diff --git a/README.md b/README.md
index 8f305679..60073284 100644
--- a/README.md
+++ b/README.md
@@ -24,12 +24,14 @@ This project was originally called Ji in its earliest iterations.
 
 ## Examples
 
-* [Simple buttons](https://github.com/HeinrichApfelmus/threepenny-gui/blob/master/src/Buttons.hs)
-* [Missing dollars question](https://github.com/HeinrichApfelmus/threepenny-gui/blob/master/src/MissingDollars.hs)
-* [Multi-user chat](https://github.com/HeinrichApfelmus/threepenny-gui/blob/master/src/Chat.hs)
-* [Replace words in a text](https://github.com/HeinrichApfelmus/threepenny-gui/blob/master/src/UseWords.hs) (Apologies for the male-centric story)
-* [BarTab - dynamic creation of widgets](https://github.com/HeinrichApfelmus/threepenny-gui/blob/master/src/BarTab.hs)
-* [Drag'N'Drop example](https://github.com/HeinrichApfelmus/threepenny-gui/blob/master/src/DragNDropExample.hs)
+* [BarTab.hs](https://github.com/HeinrichApfelmus/threepenny-gui/blob/master/src/BarTab.hs) - Dynamic creation of widgets.
+* [Buttons.hs](https://github.com/HeinrichApfelmus/threepenny-gui/blob/master/src/Buttons.hs) - Simple buttons to click on.
+* [Chat.hs](https://github.com/HeinrichApfelmus/threepenny-gui/blob/master/src/Chat.hs) - Multi-user chat.
+* [DragNDropExample.hs](https://github.com/HeinrichApfelmus/threepenny-gui/blob/master/src/DragNDropExample.hs) - Simple drag'N'drop demo.
+* [DrumMachine.hs](https://github.com/HeinrichApfelmus/threepenny-gui/blob/master/src/Chat.hs) - Specify rhythm by activating and deactivating checkboxes.
+* [MissingDollars.hs](https://github.com/HeinrichApfelmus/threepenny-gui/blob/master/src/MissingDollars.hs) - Text with configurable values.
+* [UseWords.hs](https://github.com/HeinrichApfelmus/threepenny-gui/blob/master/src/UseWords.hs)  - Text with configurable words. (Apologies for the male-centric story.)
+
 
 
 ## Challenges
@@ -39,6 +41,8 @@ This project was originally called Ji in its earliest iterations.
 As indicated, the frequent communication between browser and server
 means that Threepenny is best used as a GUI server running on localhost.
 
+The communication is done over a persistent connection using WebSockets.
+
 If you want to reduce latency, the best option is to generate JavaScript
 code and run it on the client. Consider this approach similar to [a
 shading language.](http://en.wikipedia.org/wiki/Shading_language)

From 1b3d34cffd81c586646124775f81fdb3d3c4e627 Mon Sep 17 00:00:00 2001
From: Heinrich Apfelmus <apfelmus@quantentunnel.de>
Date: Sun, 11 Aug 2013 16:00:22 +0200
Subject: [PATCH 18/41] Fix minor update to Readme. :sweat_smile:

---
 README.md | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/README.md b/README.md
index 60073284..320dad2b 100644
--- a/README.md
+++ b/README.md
@@ -28,7 +28,7 @@ This project was originally called Ji in its earliest iterations.
 * [Buttons.hs](https://github.com/HeinrichApfelmus/threepenny-gui/blob/master/src/Buttons.hs) - Simple buttons to click on.
 * [Chat.hs](https://github.com/HeinrichApfelmus/threepenny-gui/blob/master/src/Chat.hs) - Multi-user chat.
 * [DragNDropExample.hs](https://github.com/HeinrichApfelmus/threepenny-gui/blob/master/src/DragNDropExample.hs) - Simple drag'N'drop demo.
-* [DrumMachine.hs](https://github.com/HeinrichApfelmus/threepenny-gui/blob/master/src/Chat.hs) - Specify rhythm by activating and deactivating checkboxes.
+* [DrumMachine.hs](https://github.com/HeinrichApfelmus/threepenny-gui/blob/master/src/DrumMachine.hs) - Specify rhythm by activating and deactivating checkboxes.
 * [MissingDollars.hs](https://github.com/HeinrichApfelmus/threepenny-gui/blob/master/src/MissingDollars.hs) - Text with configurable values.
 * [UseWords.hs](https://github.com/HeinrichApfelmus/threepenny-gui/blob/master/src/UseWords.hs)  - Text with configurable words. (Apologies for the male-centric story.)
 

From 05f5bfd599cbf8b72b3b1fac79553635a1ad33e5 Mon Sep 17 00:00:00 2001
From: rnons <remotenonsense@gmail.com>
Date: Sun, 18 Aug 2013 18:14:16 +0800
Subject: [PATCH 19/41] Add getElementsByClassName function.

---
 src/Graphics/UI/Threepenny/Core.hs           | 12 +++++++++++-
 src/Graphics/UI/Threepenny/Internal/Core.hs  | 12 ++++++++++++
 src/Graphics/UI/Threepenny/Internal/Types.hs |  1 +
 src/Graphics/UI/driver.js                    | 12 ++++++++++++
 threepenny-gui.cabal                         |  2 ++
 5 files changed, 38 insertions(+), 1 deletion(-)

diff --git a/src/Graphics/UI/Threepenny/Core.hs b/src/Graphics/UI/Threepenny/Core.hs
index dad2bb68..fc75ed0b 100644
--- a/src/Graphics/UI/Threepenny/Core.hs
+++ b/src/Graphics/UI/Threepenny/Core.hs
@@ -17,7 +17,9 @@ module Graphics.UI.Threepenny.Core (
         getHead, getBody,
         children, text, html, attr, style, value,
     getValuesList,
-    getElementsByTagName, getElementByTagName, getElementsById, getElementById,
+    getElementsByTagName, getElementByTagName, 
+    getElementsById, getElementById,
+    getElementsByClassName,
     
     -- * Layout
     -- | Combinators for quickly creating layouts.
@@ -317,6 +319,14 @@ getElementsById
 getElementsById window name =
     mapM fromAlive =<< Core.getElementsById window name
 
+-- | Get a list of elements by particular class.  Blocks.
+getElementsByClassName
+    :: Window        -- ^ Browser window
+    -> String        -- ^ The class string.
+    -> IO [Element]  -- ^ Elements with given class.
+getElementsByClassName window cls =
+    mapM fromAlive =<< Core.getElementsByClassName window cls
+
 {-----------------------------------------------------------------------------
     Oddball
 ------------------------------------------------------------------------------}
diff --git a/src/Graphics/UI/Threepenny/Internal/Core.hs b/src/Graphics/UI/Threepenny/Internal/Core.hs
index a48444c0..35944260 100644
--- a/src/Graphics/UI/Threepenny/Internal/Core.hs
+++ b/src/Graphics/UI/Threepenny/Internal/Core.hs
@@ -40,6 +40,7 @@ module Graphics.UI.Threepenny.Internal.Core
   ,getBody
   ,getElementsByTagName
   ,getElementsById
+  ,getElementsByClassName
   ,getWindow
   ,getProp
   ,getValue
@@ -615,6 +616,17 @@ getElementsById window ids =
       Elements els -> return $ Just [Element el window | el <- els]
       _            -> return Nothing
 
+-- | Get a list of elements by particular class.  Blocks.
+getElementsByClassName
+    :: Window        -- ^ Browser window
+    -> String        -- ^ The class string.
+    -> IO [Element]  -- ^ Elements with given class.
+getElementsByClassName window cls =
+  call window (GetElementsByClassName cls) $ \signal ->
+    case signal of
+      Elements els -> return $ Just [Element el window | el <- els]
+      _            -> return Nothing
+
 -- | Get the value of an input. Blocks.
 getValue
     :: Element   -- ^ The element to get the value of.
diff --git a/src/Graphics/UI/Threepenny/Internal/Types.hs b/src/Graphics/UI/Threepenny/Internal/Types.hs
index 0816d425..c652700a 100644
--- a/src/Graphics/UI/Threepenny/Internal/Types.hs
+++ b/src/Graphics/UI/Threepenny/Internal/Types.hs
@@ -96,6 +96,7 @@ data Config = Config
 data Instruction
   = Debug String
   | SetToken Integer
+  | GetElementsByClassName String
   | GetElementsById [String]
   | GetElementsByTagName String
   | SetStyle ElementId [(String,String)]
diff --git a/src/Graphics/UI/driver.js b/src/Graphics/UI/driver.js
index 680e3f21..68988efb 100644
--- a/src/Graphics/UI/driver.js
+++ b/src/Graphics/UI/driver.js
@@ -274,6 +274,18 @@ $.fn.livechange = function(ms,trigger){
         reply({ Elements: els });
         break;
       }
+      case "GetElementsByClassName": {
+        var elements = document.getElementsByClassName(event.GetElementsByClassName);
+        var els = [];
+        var len = elements.length;
+        for(var i = 0; i < len; i++) {
+          els.push({
+            Element: elementToElid(elements[i])
+          });
+        }
+        reply({ Elements: els });
+        break;
+      }
       case "SetStyle": {
         var set = event.SetStyle;
         var id = set[0];
diff --git a/threepenny-gui.cabal b/threepenny-gui.cabal
index 8953fb9c..2cef74a3 100644
--- a/threepenny-gui.cabal
+++ b/threepenny-gui.cabal
@@ -97,6 +97,8 @@ Library
                     ,data-default
                     ,transformers
                     ,stm
+                    ,attoparsec-enumerator
+                    ,MonadCatchIO-transformers
                     
 Executable threepenny-examples-bartab
     if flag(buildExamples)

From 21e4f3645d613f75e5ceb9e69df86f9b5da008d3 Mon Sep 17 00:00:00 2001
From: Heinrich Apfelmus <apfelmus@quantentunnel.de>
Date: Tue, 27 Aug 2013 18:09:30 +0200
Subject: [PATCH 20/41] Add barebones FRP implementation that can be used in
 the traditional imperative event-driven style if desired.

---
 src/Reactive/Threepenny.hs            | 144 +++++++++++++++++
 src/Reactive/Threepenny/Memo.hs       |  43 +++++
 src/Reactive/Threepenny/PulseLatch.hs | 217 ++++++++++++++++++++++++++
 3 files changed, 404 insertions(+)
 create mode 100644 src/Reactive/Threepenny.hs
 create mode 100644 src/Reactive/Threepenny/Memo.hs
 create mode 100644 src/Reactive/Threepenny/PulseLatch.hs

diff --git a/src/Reactive/Threepenny.hs b/src/Reactive/Threepenny.hs
new file mode 100644
index 00000000..aaf50c0c
--- /dev/null
+++ b/src/Reactive/Threepenny.hs
@@ -0,0 +1,144 @@
+module Reactive.Threepenny (
+    -- * Synopsis
+    -- | Functional reactive programming.
+    --
+    -- Note: Basic functionality should work,
+    -- but recursion does not work yet
+    -- and there may be some unexpected surprises
+    -- when attaching new behaviors amd events after some
+    -- events have already occured
+    -- ("dynamic event switching").
+    
+    -- * Types
+    Event,
+    newEvent, register,
+    
+    Behavior, readValue,
+    
+    -- * Combinators
+    never, filterJust, unionWith,
+    accumE, accumB, stepper, apply,
+    module Control.Applicative,
+    
+    -- * Internal
+    onChange,
+    ) where
+
+import Control.Applicative
+
+import           Reactive.Threepenny.Memo       as Memo
+import qualified Reactive.Threepenny.PulseLatch as Prim
+
+type Pulse = Prim.Pulse
+type Latch = Prim.Latch
+
+{-----------------------------------------------------------------------------
+    Types
+------------------------------------------------------------------------------}
+newtype Event    a = E { unE :: Memo (Pulse a)           }
+newtype Behavior a = B { unB :: Memo (Latch a, Pulse ()) }
+
+{-----------------------------------------------------------------------------
+    IO
+------------------------------------------------------------------------------}
+-- | An /event handler/ is a function that takes an
+-- /event value/ and performs some computation.
+type Handler a = a -> IO ()
+
+-- | Create a new event.
+-- Also returns a function that triggers an event occurrence.
+newEvent :: IO (Event a, a -> IO ())
+newEvent = do
+    (p, fire) <- Prim.newPulse
+    return (E $ fromPure p, fire)
+
+-- | Register an event 'Handler' for an 'Event'.
+-- All registered handlers will be called whenever the event occurs.
+-- 
+-- When registering an event handler, you will also be given an action
+-- that unregisters this handler again.
+-- 
+-- > do unregisterMyHandler <- register event myHandler
+--
+-- FIXME: This does not currently work.
+register :: Event a -> Handler a -> IO (IO ())
+register e h = do
+    p <- at (unE e)     -- evaluate the memoized action
+    Prim.addHandler p h
+    return $ return ()  -- FIXME
+
+-- | Register an event 'Handler' for a 'Behavior'.
+-- All registered handlers will be called whenever the behavior changes.
+-- 
+-- However, note that this is only an approximation,
+-- as behaviors may change continuously.
+-- Consequently, handlers should be idempotent.
+onChange :: Behavior a -> Handler a -> IO ()
+onChange b h = do
+    (l,p) <- at (unB b)
+    -- This works because latches are updated before the handlers are being called.
+    Prim.addHandler p (\_ -> h =<< Prim.readLatch l)
+
+-- | Read the current value of a 'Behavior'.
+readValue :: Behavior a -> IO a
+readValue b = do
+    (l, p) <- at (unB b)
+    Prim.readLatch l
+
+
+{-----------------------------------------------------------------------------
+    Combinators
+------------------------------------------------------------------------------}
+instance Functor Event where
+    fmap f e = E $ liftMemo1 (Prim.mapP f) (unE e)
+
+never             = E $ fromPure Prim.neverP
+
+-- | Keep only those event values that are of the form 'Just'.
+filterJust e      = E $ liftMemo1 Prim.filterJustP    (unE e)
+unionWith f e1 e2 = E $ liftMemo2 (Prim.unionWithP f) (unE e1) (unE e2)
+
+apply  f x  = E $ liftMemo2 (\(l,_) p -> Prim.applyP l p) (unB f) (unE x)
+accumB a e  = B $ liftMemo1 (accumL a) (unE e)
+    where
+    accumL a p1 = do
+        (l,p2) <- Prim.accumL a p1
+        p3     <- Prim.mapP (const ()) p2
+        return (l,p3)
+
+stepper :: a -> Event a -> Behavior a
+stepper a e = accumB a (const <$> e)
+
+accumE :: a -> Event (a -> a) -> Event a
+accumE a e = E $ liftMemo1 (fmap snd . Prim.accumL a) (unE e)
+
+instance Functor Behavior where
+    fmap f b = B $ memoize $ do
+        (l1,p1) <- at (unB b)
+        l2      <- Prim.mapL f l1
+        return (l2,p1)
+
+instance Applicative Behavior where
+    pure a  = B $ fromPure (Prim.pureL a,Prim.neverP)
+    f <*> x = B $ liftMemo2 applyB (unB f) (unB x)
+        where
+        applyB (l1,p1) (l2,p2) = do
+            p3 <- Prim.unionWithP const p1 p2
+            l3 <- Prim.applyL l1 l2
+            return (l3,p3)
+
+
+{-----------------------------------------------------------------------------
+    Test
+------------------------------------------------------------------------------}
+test :: IO (Int -> IO ())
+test = do
+    (e1,fire) <- newEvent
+    let e2 = accumE 0 ((+) <$> e1)
+    register e2 print
+    
+    return fire
+
+
+
+
diff --git a/src/Reactive/Threepenny/Memo.hs b/src/Reactive/Threepenny/Memo.hs
new file mode 100644
index 00000000..bfff3598
--- /dev/null
+++ b/src/Reactive/Threepenny/Memo.hs
@@ -0,0 +1,43 @@
+{-# LANGUAGE RecursiveDo #-}
+module Reactive.Threepenny.Memo (
+    Memo, fromPure, memoize, at, liftMemo1, liftMemo2,
+    ) where
+
+import Control.Monad
+import Data.Functor
+import Data.IORef
+import System.IO.Unsafe
+
+{-----------------------------------------------------------------------------
+    Memoize time-varying values / computations
+------------------------------------------------------------------------------}
+data Memo a
+    = Const a
+    | Memoized (IORef (MemoD a))
+
+type MemoD a = Either (IO a) a
+
+fromPure = Const
+
+at :: Memo a -> IO a
+at (Const a)    = return a
+at (Memoized r) = do
+    memo <- readIORef r
+    case memo of
+        Right a -> return a
+        Left ma -> mdo
+            writeIORef r $ Right a
+            a <- ma     -- FIXME: IO is not a good MonadFix instance
+            return a
+
+memoize :: IO a -> Memo a
+memoize m = unsafePerformIO $ Memoized <$> newIORef (Left m)
+
+liftMemo1 :: (a -> IO b) -> Memo a -> Memo b
+liftMemo1 f ma = memoize $ f =<< at ma
+
+liftMemo2 :: (a -> b -> IO c) -> Memo a -> Memo b -> Memo c
+liftMemo2 f ma mb = memoize $ do
+    a <- at ma
+    b <- at mb
+    f a b
diff --git a/src/Reactive/Threepenny/PulseLatch.hs b/src/Reactive/Threepenny/PulseLatch.hs
new file mode 100644
index 00000000..fb0efcb7
--- /dev/null
+++ b/src/Reactive/Threepenny/PulseLatch.hs
@@ -0,0 +1,217 @@
+{-# LANGUAGE RecordWildCards #-}
+module Reactive.Threepenny.PulseLatch (
+    Pulse, newPulse, addHandler,
+    neverP, mapP, filterJustP, unionWithP,
+    
+    Latch,
+    pureL, mapL, applyL, accumL, applyP,
+    readLatch,
+    ) where
+
+
+import Control.Applicative
+import Control.Monad
+import Control.Monad.Trans.Class
+import Control.Monad.Trans.RWS     as Monad
+
+import Data.Hashable
+import Data.IORef
+import Data.Monoid (Endo(..))
+
+import Data.Unique.Really
+import qualified Data.Vault.Lazy   as Vault
+import qualified Data.HashMap.Lazy as Map
+
+type Vault = Vault.Vault
+type Map   = Map.HashMap
+
+
+type Build = IO
+
+{-----------------------------------------------------------------------------
+    Pulse
+------------------------------------------------------------------------------}
+type EvalP = Monad.RWST () () Vault IO
+
+runEvalP :: Vault -> EvalP a -> IO (a, Vault)
+runEvalP pulses m = do
+    (a, s, w) <- Monad.runRWST m () pulses
+    return (a, s)
+
+
+type Handler  = EvalP (IO ())
+data Priority = DoLatch | DoIO deriving (Eq,Show,Ord,Enum)
+
+instance Hashable Priority where hash = fromEnum
+
+data Pulse a = Pulse
+    { addHandlerP :: ((Unique, Priority), Handler) -> Build ()
+    , evalP       :: EvalP (Maybe a)
+    }
+
+-- Turn evaluation action into pulse that caches the value.
+cacheEval :: EvalP (Maybe a) -> Build (Pulse a)
+cacheEval e = do
+    key <- Vault.newKey
+    return $ Pulse
+        { addHandlerP = \_ -> return ()
+        , evalP = do
+            vault <- Monad.get
+            case Vault.lookup key vault of
+                Just a  -> return a
+                Nothing -> do
+                    a <- e
+                    Monad.put $ Vault.insert key a vault
+                    return a
+        }
+
+-- Add a dependency to a pulse, for the sake of keeping track of dependencies.
+dependOn :: Pulse a -> Pulse b -> Pulse a
+dependOn p q = p { addHandlerP = \h -> addHandlerP p h >> addHandlerP q h }
+
+-- Execute an action when the pulse occurs
+whenPulse :: Pulse a -> (a -> IO ()) -> Handler
+whenPulse p f = do
+    ma <- evalP p
+    case ma of
+        Just a  -> return (f a)
+        Nothing -> return $ return ()
+
+{-----------------------------------------------------------------------------
+    Latch
+------------------------------------------------------------------------------}
+data Latch a = Latch { readL :: IO a }
+
+{-----------------------------------------------------------------------------
+    Interface to the outside world.
+------------------------------------------------------------------------------}
+-- | Create a new pulse and a function to trigger it.
+newPulse :: Build (Pulse a, a -> IO ())
+newPulse = do
+    key         <- Vault.newKey
+    handlersRef <- newIORef Map.empty      -- map of handlers
+    
+    let
+        -- add handler to map
+        addHandlerP :: ((Unique, Priority), Handler) -> Build ()
+        addHandlerP (uid,m) = do
+            handlers <- readIORef handlersRef
+            case Map.lookup uid handlers of
+                Just _  -> return ()
+                Nothing -> writeIORef handlersRef $ Map.insert uid m handlers
+        
+        -- evaluate all handlers attached to this input pulse
+        fireP a = do
+            let pulses = Vault.insert key (Just a) $ Vault.empty
+            handlers <- readIORef handlersRef
+            (ms, _)  <- runEvalP pulses $ sequence $ 
+                   [m | ((_,DoLatch),m) <- Map.toList handlers]
+                ++ [m | ((_,DoIO   ),m) <- Map.toList handlers]  
+            sequence_ ms
+        
+        evalP = join . Vault.lookup key <$> Monad.get
+
+    return (Pulse {..}, fireP)
+
+-- | Register a handler to be executed whenever a pulse occurs.
+--
+-- FIXME: Cannot unregister a handler again.
+addHandler :: Pulse a -> (a -> IO ()) -> Build ()
+addHandler p f = do
+    uid <- newUnique
+    addHandlerP p ((uid, DoIO), whenPulse p f)
+
+-- | Read the value of a 'Latch' at a particular moment in Build.
+readLatch :: Latch a -> Build a
+readLatch = readL
+
+{-----------------------------------------------------------------------------
+    Pulse and Latch
+    Public API
+------------------------------------------------------------------------------}
+-- | Create a new pulse that never occurs.
+neverP :: Pulse a
+neverP = Pulse
+    { addHandlerP = const $ return ()
+    , evalP       = return Nothing
+    }
+
+-- | Map a function over pulses.
+mapP :: (a -> b) -> Pulse a -> Build (Pulse b)
+mapP f p = (`dependOn` p) <$> cacheEval (return . fmap f =<< evalP p)
+
+-- | Filter occurrences. Only keep those of the form 'Just'.
+filterJustP :: Pulse (Maybe a) -> Build (Pulse a)
+filterJustP p = (`dependOn` p) <$> cacheEval (return . join =<< evalP p)
+
+-- | Pulse that occurs when either of the pulses occur.
+-- Combines values with the indicated function when both occur.
+unionWithP :: (a -> a -> a) -> Pulse a -> Pulse a -> Build (Pulse a)
+unionWithP f p q = (`dependOn` q) . (`dependOn` p) <$> cacheEval eval
+    where
+    eval = do
+        x <- evalP p
+        y <- evalP q
+        return $ case (x,y) of
+            (Nothing, Nothing) -> Nothing
+            (Just a , Nothing) -> Just a
+            (Nothing, Just a ) -> Just a
+            (Just a1, Just a2) -> Just $ f a1 a2
+
+-- | Apply the current latch value whenever the pulse occurs.
+applyP :: Latch (a -> b) -> Pulse a -> Build (Pulse b)
+applyP l p = (`dependOn` p) <$> cacheEval eval
+    where
+    eval = do
+        f <- lift $ readL l
+        a <- evalP p
+        return $ f <$> a
+
+-- | Accumulate values in a latch.
+accumL :: a -> Pulse (a -> a) -> Build (Latch a, Pulse a)
+accumL a p1 = do
+    -- IORef to hold the current latch value
+    latch <- newIORef a
+    let l1 = Latch { readL = readIORef latch }
+
+    -- calculate new pulse from old value
+    l2 <- mapL (flip ($)) l1
+    p2 <- applyP l2 p1
+
+    -- register handler to update latch
+    uid <- newUnique
+    let handler = whenPulse p2 $ (writeIORef latch $!)
+    addHandlerP p2 ((uid, DoLatch), handler)
+    
+    return (l1,p2)
+
+-- | Latch whose value stays constant.
+pureL :: a -> Latch a
+pureL a = Latch { readL = return a }
+
+-- | Map a function over latches.
+--
+-- Evaluated only when needed, result is not cached.
+mapL :: (a -> b) -> Latch a -> Build (Latch b)
+mapL f l = return $ Latch { readL = f <$> readL l } 
+
+-- | Apply two current latch values
+--
+-- Evaluated only when needed, result is not cached.
+applyL :: Latch (a -> b) -> Latch a -> Build (Latch b)
+applyL l1 l2 = return $ Latch { readL = readL l1 <*> readL l2 }
+
+{-----------------------------------------------------------------------------
+    Test
+------------------------------------------------------------------------------}
+test :: IO (Int -> IO ())
+test = do
+    (p1, fire) <- newPulse
+    p2 <- mapP (+) p1
+    (l1,_) <- accumL 0 p2
+    l2 <- mapL const l1
+    p3 <- applyP l2 p1
+    addHandler p3 print
+    
+    return fire
+

From 3e29585d6f20c18c9313de77630fa4cd4a296733 Mon Sep 17 00:00:00 2001
From: Heinrich Apfelmus <apfelmus@quantentunnel.de>
Date: Wed, 28 Aug 2013 00:29:54 +0200
Subject: [PATCH 21/41] Use new FRP Event type to handle events on the server.
 Fix old issue where registering an event twice would remove old event
 handlers.

---
 src/Graphics/UI/Threepenny/Core.hs           | 13 ++-
 src/Graphics/UI/Threepenny/Internal/Core.hs  | 84 ++++++++++----------
 src/Graphics/UI/Threepenny/Internal/Types.hs | 19 +++--
 src/Graphics/UI/Threepenny/JQuery.hs         |  2 +-
 src/Graphics/UI/Threepenny/Timer.hs          |  2 +-
 src/Reactive/Threepenny.hs                   | 25 ++++--
 6 files changed, 81 insertions(+), 64 deletions(-)

diff --git a/src/Graphics/UI/Threepenny/Core.hs b/src/Graphics/UI/Threepenny/Core.hs
index fc75ed0b..b55dccf0 100644
--- a/src/Graphics/UI/Threepenny/Core.hs
+++ b/src/Graphics/UI/Threepenny/Core.hs
@@ -29,7 +29,7 @@ module Graphics.UI.Threepenny.Core (
     -- * Events
     -- | For a list of predefined events, see "Graphics.UI.Threepenny.Events".
     EventData(..), domEvent, on, disconnect,
-    module Control.Event,
+    module Reactive.Threepenny,
     
     -- * Attributes
     -- | For a list of predefined attributes, see "Graphics.UI.Threepenny.Attributes".
@@ -55,11 +55,11 @@ import Data.Maybe (listToMaybe)
 import Data.Functor
 import Data.String (fromString)
 import Control.Concurrent.MVar
-import Control.Event
 import Control.Monad
 import Control.Monad.IO.Class
 import Network.URI
 import Text.JSON
+import Reactive.Threepenny
 
 import qualified Graphics.UI.Threepenny.Internal.Core  as Core
 import Graphics.UI.Threepenny.Internal.Core
@@ -404,7 +404,12 @@ domEvent
         --   the name is @click@ and so on.
     -> Element          -- ^ Element where the event is to occur.
     -> Event EventData
-domEvent name element = Control.Event.Event $ \handler -> do
+domEvent name element =
+    Core.newEventDelayed $ \(e,handler) ->
+        flip updateElement element $ \el -> void $ do
+            register (Core.bind name el) handler
+
+{-   
     ref <- newIORef $ return ()
     let
         -- register handler and remember unregister function
@@ -418,7 +423,7 @@ domEvent name element = Control.Event.Event $ \handler -> do
     
     register'
     return unregister'
-
+-}
 
 -- | Event that occurs whenever the client has disconnected,
 -- be it by closing the browser window or by exception.
diff --git a/src/Graphics/UI/Threepenny/Internal/Core.hs b/src/Graphics/UI/Threepenny/Internal/Core.hs
index 35944260..4c18d70d 100644
--- a/src/Graphics/UI/Threepenny/Internal/Core.hs
+++ b/src/Graphics/UI/Threepenny/Internal/Core.hs
@@ -16,7 +16,7 @@ module Graphics.UI.Threepenny.Internal.Core
   -- $eventhandling
   ,bind
   ,disconnect
-  ,module Control.Event
+  ,module Reactive.Threepenny
   
   -- * Setting attributes
   -- $settingattributes
@@ -77,7 +77,7 @@ import           Control.Concurrent
 import           Control.Concurrent.Chan.Extra
 import           Control.Concurrent.Delay
 import qualified Control.Exception
-import           Control.Event
+import           Reactive.Threepenny
 import           Control.Monad
 import           Control.Monad.IO.Class
 import qualified "MonadCatchIO-transformers" Control.Monad.CatchIO as E
@@ -176,30 +176,17 @@ routeCommunication worker server =
 
 -- | Make a new session.
 newSession :: ServerState -> (URI,[(String, String)]) -> Integer -> IO Session
-newSession server info token = do
-    signals          <- newChan
-    instructions     <- newChan
-    (event, handler) <- newEventsTagged
-    ids      <- newMVar [0..]
-    mutex    <- newMVar ()
-    now      <- getCurrentTime
-    conState <- newMVar (Disconnected now)
-    threadId <- myThreadId
-    closures <- newMVar [0..]
-    return $ Session
-        { sSignals      = signals
-        , sInstructions = instructions
-        , sMutex        = mutex
-        , sEvent        = event
-        , sEventHandler = handler
-        , sElementIds   = ids
-        , sToken        = token
-        , sConnectedState = conState
-        , sThreadId    = threadId
-        , sClosures    = closures
-        , sStartInfo   = info
-        , sServerState = server
-        }
+newSession sServerState sStartInfo sToken = do
+    sSignals          <- newChan
+    sInstructions     <- newChan
+    sMutex            <- newMVar ()
+    sEventHandlers    <- newMVar M.empty
+    sElementIds       <- newMVar [0..]
+    now               <- getCurrentTime
+    sConnectedState   <- newMVar (Disconnected now)
+    sThreadId         <- myThreadId
+    sClosures         <- newMVar [0..]
+    return $ Session {..}
 
 -- | Make a new session and add it to the server
 createSession :: (Session -> IO void) -> ServerState -> Snap Session
@@ -462,14 +449,28 @@ handleEvents window@(Session{..}) = do
     signal <- getSignal window
     case signal of
         Threepenny.Event (elid,eventType,params) -> do
-            sEventHandler ((elid,eventType), EventData params)
+            handleEvent1 window ((elid,eventType),EventData params)
             handleEvents window
         Quit () -> do
-            sEventHandler (("","quit"), EventData [])
+            handleEvent1 window (("","quit"),EventData [])
             -- do not continue handling events
         _       -> do
             handleEvents window
-            
+
+-- | Add a new event handler for a given key
+addEventHandler :: Window -> (EventKey, Handler EventData) -> IO () 
+addEventHandler Session{..} (key,handler) =
+    modifyMVar_ sEventHandlers $ return .
+        M.insertWith (\h1 h a -> h1 a >> h a) key handler        
+
+-- | Handle a single event
+handleEvent1 :: Window -> (EventKey,EventData) -> IO ()
+handleEvent1 Session{..} (key,params) = do
+    handlers <- readMVar sEventHandlers
+    case M.lookup key handlers of
+        Just handler -> handler params
+        Nothing      -> return ()
+
 -- Get the latest signal sent from the client.
 getSignal :: Window -> IO Signal
 getSignal (Session{..}) = readChan sSignals
@@ -480,25 +481,27 @@ bind
     -> Element              -- ^ The element to bind to.
     -> Event EventData      -- ^ The event handler.
 bind eventType (Element el@(ElementId elid) session) =
-    Control.Event.Event register
-    where
-    key        = (elid, eventType)
-    register h = do
+    newEventDelayed $ \(_,fire) -> do
+        let key = (elid, eventType)
+        -- register with client if it has never been registered on the server
+        handlers <- readMVar $ sEventHandlers session
+        when (not $ key `M.member` handlers) $
+            run session $ Bind eventType el (Closure key)
         -- register with server
-        unregister <- Control.Event.register (sEvent session key) h
-        -- register with client
-        run session $ Bind eventType el (Closure key)
-        return unregister
+        addEventHandler session (key, fire)
 
 -- | Event that occurs when the client has disconnected.
 disconnect :: Window -> Event ()
-disconnect window = () <$ sEvent window ("","quit")
+disconnect window = () <$ e
+    where
+    e = newEventDelayed $ \(_,fire) ->
+        addEventHandler window (("", "quit"), fire)
 
 -- Make a uniquely numbered event handler.
 newClosure :: Window -> String -> String -> ([Maybe String] -> IO ()) -> IO Closure
-newClosure window@(Session{..}) eventType elid thunk = do
+newClosure window eventType elid thunk = do
     let key = (elid, eventType)
-    _ <- register (sEvent key) $ \(EventData xs) -> thunk xs
+    addEventHandler window (key, \(EventData xs) -> thunk xs)
     return (Closure key)
 
 {-----------------------------------------------------------------------------
@@ -571,7 +574,6 @@ newElement :: Window      -- ^ Browser window in which context to create the ele
            -> String      -- ^ The tag name.
            -> IO Element  -- ^ A tag reference. Non-blocking.
 newElement session@(Session{..}) tagName = do
-    -- TODO: Remove the need to specify in which browser window is to be created
     elid <- modifyMVar sElementIds $ \elids ->
         return (tail elids,"*" ++ show (head elids) ++ ":" ++ tagName)
     return (Element (ElementId elid) session)
diff --git a/src/Graphics/UI/Threepenny/Internal/Types.hs b/src/Graphics/UI/Threepenny/Internal/Types.hs
index c652700a..2dbee508 100644
--- a/src/Graphics/UI/Threepenny/Internal/Types.hs
+++ b/src/Graphics/UI/Threepenny/Internal/Types.hs
@@ -7,7 +7,7 @@ import Prelude              hiding (init)
 
 import Control.Applicative
 import Control.Concurrent
-import qualified Control.Event as E
+import qualified Reactive.Threepenny as E
 import Data.ByteString               (ByteString)
 import Data.Map             (Map)
 import Data.Time
@@ -30,7 +30,7 @@ instance Show Element where
 
 -- | An opaque reference to an element in the DOM.
 data ElementId = ElementId String
-  deriving (Data,Typeable,Show)
+  deriving (Data,Typeable,Show,Eq,Ord)
 
 instance JSON ElementId where
   showJSON (ElementId o) = showJSON o
@@ -38,14 +38,13 @@ instance JSON ElementId where
     obj <- readJSON obj
     ElementId <$> valFromObj "Element" obj
 
-  
+
 -- | A client session. This type is opaque, you don't need to inspect it.
 data Session = Session
   { sSignals        :: Chan Signal
   , sInstructions   :: Chan Instruction
   , sMutex          :: MVar ()
-  , sEvent          :: EventKey -> E.Event EventData
-  , sEventHandler   :: E.Handler (EventKey, EventData)
+  , sEventHandlers  :: MVar (Map EventKey (E.Handler EventData))
   , sClosures       :: MVar [Integer]
   , sElementIds     :: MVar [Integer]
   , sToken          :: Integer
@@ -55,9 +54,10 @@ data Session = Session
   , sServerState    :: ServerState
   }
 
-type Sessions  = Map Integer Session
-type MimeType  = ByteString
-type Filepaths = (Integer, Map ByteString (FilePath, MimeType))
+type Sessions     = Map Integer Session
+type EventKey     = (String, String)
+type MimeType     = ByteString
+type Filepaths    = (Integer, Map ByteString (FilePath, MimeType))
 
 data ServerState = ServerState
     { sSessions :: MVar Sessions
@@ -65,7 +65,6 @@ data ServerState = ServerState
     , sDirs     :: MVar Filepaths
     }
 
-type EventKey = (String, String)
 
 -- | The client browser window.
 type Window = Session
@@ -154,7 +153,7 @@ nullable v      = Just <$> readJSON v
 
 -- | An opaque reference to a closure that the event manager uses to
 --   trigger events signalled by the client.
-data Closure = Closure (String,String)
+data Closure = Closure EventKey
     deriving (Typeable,Data,Show)
 
 {-----------------------------------------------------------------------------
diff --git a/src/Graphics/UI/Threepenny/JQuery.hs b/src/Graphics/UI/Threepenny/JQuery.hs
index ba7c08f6..bd8adc1a 100644
--- a/src/Graphics/UI/Threepenny/JQuery.hs
+++ b/src/Graphics/UI/Threepenny/JQuery.hs
@@ -1,7 +1,6 @@
 {-# OPTIONS -fno-warn-wrong-do-bind #-}
 module Graphics.UI.Threepenny.JQuery where
 
-import Control.Event
 import Control.Arrow
 import Data.Char
 import Data.Default
@@ -10,6 +9,7 @@ import Graphics.UI.Threepenny.Core
 import qualified Graphics.UI.Threepenny.Internal.Core as Core
 import qualified Graphics.UI.Threepenny.Internal.Types as Core
 import Text.JSON
+import Reactive.Threepenny
 
 data Easing = Swing | Linear
   deriving (Eq,Enum,Show)
diff --git a/src/Graphics/UI/Threepenny/Timer.hs b/src/Graphics/UI/Threepenny/Timer.hs
index db735e21..39a90b89 100644
--- a/src/Graphics/UI/Threepenny/Timer.hs
+++ b/src/Graphics/UI/Threepenny/Timer.hs
@@ -14,9 +14,9 @@ module Graphics.UI.Threepenny.Timer (
 
 import Data.Typeable
 import Control.Monad (when, forever, void)
-import Control.Event
 import Control.Concurrent
 import Control.Concurrent.STM
+import Reactive.Threepenny
 
 import Graphics.UI.Threepenny.Core
 
diff --git a/src/Reactive/Threepenny.hs b/src/Reactive/Threepenny.hs
index aaf50c0c..d81fb207 100644
--- a/src/Reactive/Threepenny.hs
+++ b/src/Reactive/Threepenny.hs
@@ -10,10 +10,10 @@ module Reactive.Threepenny (
     -- ("dynamic event switching").
     
     -- * Types
-    Event,
-    newEvent, register,
+    Handler, Event,
+    newEvent, newEventDelayed, register,
     
-    Behavior, readValue,
+    Behavior, currentValue,
     
     -- * Combinators
     never, filterJust, unionWith,
@@ -47,11 +47,22 @@ type Handler a = a -> IO ()
 
 -- | Create a new event.
 -- Also returns a function that triggers an event occurrence.
-newEvent :: IO (Event a, a -> IO ())
+newEvent :: IO (Event a, Handler a)
 newEvent = do
     (p, fire) <- Prim.newPulse
     return (E $ fromPure p, fire)
 
+
+-- | Create a new event with some delayed initialization procedure.
+--
+-- The argument will be called when a handler is registered at the event.
+-- This happens only once for each shared instance of the event.
+newEventDelayed :: Handler (Event a, Handler a) -> Event a
+newEventDelayed handler = E $ memoize $ do
+    (p, fire) <- Prim.newPulse
+    handler (E $ fromPure p, fire)
+    return p
+
 -- | Register an event 'Handler' for an 'Event'.
 -- All registered handlers will be called whenever the event occurs.
 -- 
@@ -80,8 +91,8 @@ onChange b h = do
     Prim.addHandler p (\_ -> h =<< Prim.readLatch l)
 
 -- | Read the current value of a 'Behavior'.
-readValue :: Behavior a -> IO a
-readValue b = do
+currentValue :: Behavior a -> IO a
+currentValue b = do
     (l, p) <- at (unB b)
     Prim.readLatch l
 
@@ -135,7 +146,7 @@ test :: IO (Int -> IO ())
 test = do
     (e1,fire) <- newEvent
     let e2 = accumE 0 ((+) <$> e1)
-    register e2 print
+    _ <- register e2 print
     
     return fire
 

From 1ceb4cc1cb86bf6082321bb293309cb651a6b799 Mon Sep 17 00:00:00 2001
From: Heinrich Apfelmus <apfelmus@quantentunnel.de>
Date: Wed, 28 Aug 2013 00:35:41 +0200
Subject: [PATCH 22/41] Update 'DrumMachine' example to use FRP.

---
 src/DrumMachine.hs | 13 +++++--------
 1 file changed, 5 insertions(+), 8 deletions(-)

diff --git a/src/DrumMachine.hs b/src/DrumMachine.hs
index f4bf0bac..4b5bdc0a 100644
--- a/src/DrumMachine.hs
+++ b/src/DrumMachine.hs
@@ -56,15 +56,12 @@ setup w = void $ do
     getBody w #+ [UI.div #. "wrap" #+ (status : map element elInstruments)]
     
     timer   <- UI.timer # set UI.interval (bpm2ms defaultBpm)
-    refBeat <- newIORef 0
-    
-    -- play sounds on timer events
-    on UI.tick timer $ const $ void $ do
-        -- get and increase beat count
-        beat <- readIORef refBeat
-        writeIORef refBeat $ (beat + 1) `mod` (beats * bars)
+    let
+        eBeat :: Event Int
+        eBeat = accumE 0 $ (\beat -> (beat + 1) `mod` (beats * bars)) <$ UI.tick timer
+    _ <- register eBeat $ \beat -> do
+        -- display beat count
         element elTick # set text (show $ beat + 1)
-        
         -- play corresponding sounds
         sequence_ $ map (!! beat) kit
     

From 4b2b66daad2cd367ca85088eaa6db026f933b3ee Mon Sep 17 00:00:00 2001
From: Heinrich Apfelmus <apfelmus@quantentunnel.de>
Date: Wed, 28 Aug 2013 11:50:03 +0200
Subject: [PATCH 23/41] Update .cabal file.

---
 .gitignore           |  1 +
 src/UseWords.hs      |  4 ++--
 threepenny-gui.cabal | 13 +++++++++++--
 3 files changed, 14 insertions(+), 4 deletions(-)

diff --git a/.gitignore b/.gitignore
index 2dbf144d..13598e02 100644
--- a/.gitignore
+++ b/.gitignore
@@ -6,3 +6,4 @@ TAGS
 log
 *.DS_Store
 /Material/
+/haddocks.html
diff --git a/src/UseWords.hs b/src/UseWords.hs
index 9981929c..6d59aa0c 100644
--- a/src/UseWords.hs
+++ b/src/UseWords.hs
@@ -11,10 +11,10 @@ import Text.Parsec
 
 #ifdef CABAL
 import qualified  "threepenny-gui" Graphics.UI.Threepenny as UI
-import "threepenny-gui" Graphics.UI.Threepenny.Core hiding (string)
+import "threepenny-gui" Graphics.UI.Threepenny.Core hiding (string, (<|>), many)
 #else
 import qualified Graphics.UI.Threepenny as UI
-import Graphics.UI.Threepenny.Core hiding (string)
+import Graphics.UI.Threepenny.Core hiding (string, (<|>), many)
 #endif
 import Paths
 import System.FilePath ((</>))
diff --git a/threepenny-gui.cabal b/threepenny-gui.cabal
index 2cef74a3..30410bfa 100644
--- a/threepenny-gui.cabal
+++ b/threepenny-gui.cabal
@@ -18,11 +18,14 @@ Description:
     NOTE: This library contains examples, but they are not built by default.
     To build and install the example, use the @buildExamples@ flag like this
     .
-    @cabal install reactive-banana-threepenny -fbuildExamples@
+    @cabal install threepenny-gui -fbuildExamples@
     .
     Changelog:
     .
+    * 0.3.0.0 - Snapshot release. Browser communication with WebSockets. First stab at FRP integration.
+    .
     * 0.2.0.0 - Snapshot release. First stab at easy JavaScript FFI.
+    .
     * 0.1.0.0 - Initial release.
 
 License:             BSD3
@@ -60,7 +63,7 @@ Source-repository head
 Library
   Hs-source-dirs:    src
   Exposed-modules:
-                     Control.Event
+                     Reactive.Threepenny
                     ,Graphics.UI.Threepenny
                     ,Graphics.UI.Threepenny.Attributes
                     ,Graphics.UI.Threepenny.Core
@@ -72,12 +75,15 @@ Library
                     ,Graphics.UI.Threepenny.Timer
   Other-modules:
                      Control.Concurrent.Chan.Extra
+                    ,Control.Event
                     ,Control.Monad.Extra
                     ,Control.Monad.IO
                     ,Control.Concurrent.Delay
                     ,Graphics.UI.Threepenny.Internal.Core
                     ,Graphics.UI.Threepenny.Internal.Resources
                     ,Graphics.UI.Threepenny.Internal.Types
+                    ,Reactive.Threepenny.PulseLatch
+                    ,Reactive.Threepenny.Memo
                     ,Paths_threepenny_gui
   CPP-Options:      -DCABAL
   Build-depends:     base                      >= 4     && < 5
@@ -88,6 +94,9 @@ Library
                     ,text
                     ,safe
                     ,containers
+                    ,unordered-containers
+                    ,hashable
+                    ,vault == 0.3.*
                     ,bytestring
                     ,json >= 0.4.4 && < 0.6
                     ,time

From 50e658fc56dc5cb5d95a0f50b52e35b35ea477e8 Mon Sep 17 00:00:00 2001
From: Heinrich Apfelmus <apfelmus@quantentunnel.de>
Date: Wed, 28 Aug 2013 16:56:56 +0200
Subject: [PATCH 24/41] Correct initialization for domEvents: Memoize event
 name instead of relying on sharing.

---
 src/Graphics/UI/Threepenny/Core.hs           | 65 +++++++++++++-------
 src/Graphics/UI/Threepenny/Internal/Core.hs  | 48 +++++++++------
 src/Graphics/UI/Threepenny/Internal/Types.hs | 12 ++--
 src/Reactive/Threepenny.hs                   | 32 +++++++---
 4 files changed, 104 insertions(+), 53 deletions(-)

diff --git a/src/Graphics/UI/Threepenny/Core.hs b/src/Graphics/UI/Threepenny/Core.hs
index b55dccf0..fb10dc05 100644
--- a/src/Graphics/UI/Threepenny/Core.hs
+++ b/src/Graphics/UI/Threepenny/Core.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveDataTypeable, RecordWildCards #-}
 module Graphics.UI.Threepenny.Core (
     -- * Guide
     -- $guide
@@ -51,6 +51,7 @@ module Graphics.UI.Threepenny.Core (
 
 import Data.Dynamic
 import Data.IORef
+import qualified Data.Map as Map
 import Data.Maybe (listToMaybe)
 import Data.Functor
 import Data.String (fromString)
@@ -67,7 +68,7 @@ import Graphics.UI.Threepenny.Internal.Core
      ToJS, FFI, ffi, JSFunction,
      debug, clear, callFunction, runFunction, callDeferredFunction, atomic, )
 import qualified Graphics.UI.Threepenny.Internal.Types as Core
-import Graphics.UI.Threepenny.Internal.Types (Window, Config, EventData)
+import Graphics.UI.Threepenny.Internal.Types (Window, Config, EventData, Session(..))
 
 {-----------------------------------------------------------------------------
     Guide
@@ -149,7 +150,10 @@ cookies = mkReadAttr Core.getRequestCookies
 type Value = String
 
 -- | Reference to an element in the DOM of the client window.
-newtype Element = Element (MVar Elem) deriving (Typeable)
+data Element = Element Core.ElementEvents (MVar Elem) deriving (Typeable)
+-- Element events mvar
+--      events = Events associated to this element
+--      mvar   = Current state of the MVar
 data    Elem
     = Alive Core.Element                       -- element exists in a window
     | Limbo Value (Window -> IO Core.Element)  -- still needs to be created
@@ -158,11 +162,13 @@ data    Elem
 -- Note that multiple MVars may now point to the same live reference,
 -- but this is ok since live references never change.
 fromAlive :: Core.Element -> IO Element
-fromAlive e = Element <$> newMVar (Alive e)
+fromAlive e@(Core.Element elid Session{..}) = do
+    Just events <- Map.lookup elid <$> readMVar sElementEvents
+    Element events <$> newMVar (Alive e)
 
 -- Update an element that may be in Limbo.
 updateElement :: (Core.Element -> IO ()) -> Element -> IO ()
-updateElement f (Element me) = do
+updateElement f (Element _ me) = do
     e <- takeMVar me
     case e of
         Alive e -> do   -- update immediately
@@ -175,13 +181,22 @@ updateElement f (Element me) = do
 -- TODO: 1. Throw exception if the element exists in another window.
 --       2. Don't throw exception, but move the element across windows.
 manifestElement :: Window -> Element -> IO Core.Element
-manifestElement w (Element me) = do
-    e1 <- takeMVar me
-    e2 <- case e1 of
-        Alive e        -> return e
-        Limbo v create -> do { e2 <- create w; Core.setAttr "value" v e2; return e2 }
-    putMVar me $ Alive e2
-    return e2
+manifestElement w (Element events me) = do
+        e1 <- takeMVar me
+        e2 <- case e1 of
+            Alive e        -> return e
+            Limbo v create -> do
+                e2 <- create w
+                Core.setAttr "value" v e2
+                rememberEvents events e2    -- save events in session data
+                return e2
+        putMVar me $ Alive e2
+        return e2
+    
+    where
+    rememberEvents events (Core.Element elid Session{..}) =
+        modifyMVar_ sElementEvents $ return . Map.insert elid events
+
 
 -- Append a child element to a parent element. Non-blocking.
 appendTo
@@ -197,9 +212,18 @@ appendTo parent child = do
 mkElement
     :: String           -- ^ Tag name
     -> IO Element
-mkElement tag = Element <$> newMVar (Limbo "" $ \w -> Core.newElement w tag)
+mkElement tag = do
+    -- create element in Limbo
+    ref <- newMVar (Limbo "" $ \w -> Core.newElement w tag)
+    -- create events and initialize them when element becomes Alive
+    let
+        initializeEvent (name,_,handler) = 
+            flip updateElement (Element undefined ref) $ \e -> do
+                Core.bind name e handler
+    events  <- newEventsNamed initializeEvent
+    return $ Element events ref
 
--- | Retreive the browser 'Window' in which the element resides.
+-- | Retrieve the browser 'Window' in which the element resides.
 -- 
 -- Note that elements do not reside in any browser window when they are first created.
 -- To move the element to a particular browser window,
@@ -208,7 +232,7 @@ mkElement tag = Element <$> newMVar (Limbo "" $ \w -> Core.newElement w tag)
 -- WARNING: The ability to move elements from one browser window to another
 -- is currently not implemented yet.
 getWindow :: Element -> IO (Maybe Window)
-getWindow (Element ref) = do
+getWindow (Element _ ref) = do
     e1 <- readMVar ref
     return $ case e1 of
         Alive e   -> Just $ Core.getWindow e
@@ -251,8 +275,8 @@ style = mkWriteAttr (updateElement . Core.setStyle)
 value :: Attr Element String
 value = mkReadWriteAttr get set
     where
-    get   (Element ref) = getValue =<< readMVar ref
-    set v (Element ref) = updateMVar (setValue v) ref
+    get   (Element _ ref) = getValue =<< readMVar ref
+    set v (Element _ ref) = updateMVar (setValue v) ref
     
     getValue (Limbo v _) = return v
     getValue (Alive e  ) = Core.getValue e
@@ -343,7 +367,7 @@ fromProp :: String -> (JSValue -> a) -> (a -> JSValue) -> Attr Element a
 fromProp name from to = mkReadWriteAttr get set
     where
     set x = updateElement (Core.setProp name $ to x)
-    get (Element ref) = do
+    get (Element _ ref) = do
         me <- readMVar ref
         case me of
             Limbo _ _ -> error "'checked' attribute: element must be in a browser window"
@@ -404,10 +428,7 @@ domEvent
         --   the name is @click@ and so on.
     -> Element          -- ^ Element where the event is to occur.
     -> Event EventData
-domEvent name element =
-    Core.newEventDelayed $ \(e,handler) ->
-        flip updateElement element $ \el -> void $ do
-            register (Core.bind name el) handler
+domEvent name (Element events _) = events name
 
 {-   
     ref <- newIORef $ return ()
diff --git a/src/Graphics/UI/Threepenny/Internal/Core.hs b/src/Graphics/UI/Threepenny/Internal/Core.hs
index 4c18d70d..afe240b1 100644
--- a/src/Graphics/UI/Threepenny/Internal/Core.hs
+++ b/src/Graphics/UI/Threepenny/Internal/Core.hs
@@ -181,12 +181,16 @@ newSession sServerState sStartInfo sToken = do
     sInstructions     <- newChan
     sMutex            <- newMVar ()
     sEventHandlers    <- newMVar M.empty
+    sElementEvents    <- newMVar M.empty
+    sEventQuit        <- newEvent
     sElementIds       <- newMVar [0..]
     now               <- getCurrentTime
     sConnectedState   <- newMVar (Disconnected now)
     sThreadId         <- myThreadId
     sClosures         <- newMVar [0..]
-    return $ Session {..}
+    let session = Session {..}
+    initializeElementEvents session    
+    return session
 
 -- | Make a new session and add it to the server
 createSession :: (Session -> IO void) -> ServerState -> Snap Session
@@ -452,7 +456,7 @@ handleEvents window@(Session{..}) = do
             handleEvent1 window ((elid,eventType),EventData params)
             handleEvents window
         Quit () -> do
-            handleEvent1 window (("","quit"),EventData [])
+            snd sEventQuit ()
             -- do not continue handling events
         _       -> do
             handleEvents window
@@ -463,6 +467,7 @@ addEventHandler Session{..} (key,handler) =
     modifyMVar_ sEventHandlers $ return .
         M.insertWith (\h1 h a -> h1 a >> h a) key handler        
 
+
 -- | Handle a single event
 handleEvent1 :: Window -> (EventKey,EventData) -> IO ()
 handleEvent1 Session{..} (key,params) = do
@@ -475,27 +480,34 @@ handleEvent1 Session{..} (key,params) = do
 getSignal :: Window -> IO Signal
 getSignal (Session{..}) = readChan sSignals
 
--- | Return an 'Event' associated to an 'Element'.
+-- | Bind an event handler for a dom event to an 'Element'.
 bind
     :: String               -- ^ The eventType, see any DOM documentation for a list of these.
     -> Element              -- ^ The element to bind to.
-    -> Event EventData      -- ^ The event handler.
-bind eventType (Element el@(ElementId elid) session) =
-    newEventDelayed $ \(_,fire) -> do
-        let key = (elid, eventType)
-        -- register with client if it has never been registered on the server
-        handlers <- readMVar $ sEventHandlers session
-        when (not $ key `M.member` handlers) $
-            run session $ Bind eventType el (Closure key)
-        -- register with server
-        addEventHandler session (key, fire)
-
--- | Event that occurs when the client has disconnected.
+    -> Handler EventData    -- ^ The event handler to bind.
+    -> IO ()
+bind eventType (Element el@(ElementId elid) session) handler = do
+    let key = (elid, eventType)
+    -- register with client if it has never been registered on the server
+    handlers <- readMVar $ sEventHandlers session
+    when (not $ key `M.member` handlers) $
+        run session $ Bind eventType el (Closure key)
+    -- register with server
+    addEventHandler session (key, handler)
+
+-- | Register event handler that occurs when the client has disconnected.
 disconnect :: Window -> Event ()
-disconnect window = () <$ e
+disconnect = fst . sEventQuit
+
+
+initializeElementEvents :: Window -> IO ()
+initializeElementEvents session@(Session{..}) = do
+        initEvents =<< getHead session
+        initEvents =<< getBody session
     where
-    e = newEventDelayed $ \(_,fire) ->
-        addEventHandler window (("", "quit"), fire)
+    initEvents el@(Element elid _) = do
+        x <- newEventsNamed $ \(name,_,handler) -> bind name el handler
+        modifyMVar_ sElementEvents $ return . M.insert elid x
 
 -- Make a uniquely numbered event handler.
 newClosure :: Window -> String -> String -> ([Maybe String] -> IO ()) -> IO Closure
diff --git a/src/Graphics/UI/Threepenny/Internal/Types.hs b/src/Graphics/UI/Threepenny/Internal/Types.hs
index 2dbee508..9e643812 100644
--- a/src/Graphics/UI/Threepenny/Internal/Types.hs
+++ b/src/Graphics/UI/Threepenny/Internal/Types.hs
@@ -45,6 +45,8 @@ data Session = Session
   , sInstructions   :: Chan Instruction
   , sMutex          :: MVar ()
   , sEventHandlers  :: MVar (Map EventKey (E.Handler EventData))
+  , sElementEvents  :: MVar (Map ElementId ElementEvents)
+  , sEventQuit      :: (E.Event (), E.Handler ())
   , sClosures       :: MVar [Integer]
   , sElementIds     :: MVar [Integer]
   , sToken          :: Integer
@@ -54,10 +56,12 @@ data Session = Session
   , sServerState    :: ServerState
   }
 
-type Sessions     = Map Integer Session
-type EventKey     = (String, String)
-type MimeType     = ByteString
-type Filepaths    = (Integer, Map ByteString (FilePath, MimeType))
+type Sessions      = Map Integer Session
+type MimeType      = ByteString
+type Filepaths     = (Integer, Map ByteString (FilePath, MimeType))
+
+type EventKey      = (String, String)
+type ElementEvents = String -> E.Event EventData
 
 data ServerState = ServerState
     { sSessions :: MVar Sessions
diff --git a/src/Reactive/Threepenny.hs b/src/Reactive/Threepenny.hs
index d81fb207..aeb65d86 100644
--- a/src/Reactive/Threepenny.hs
+++ b/src/Reactive/Threepenny.hs
@@ -11,7 +11,7 @@ module Reactive.Threepenny (
     
     -- * Types
     Handler, Event,
-    newEvent, newEventDelayed, register,
+    newEvent, newEventsNamed, register,
     
     Behavior, currentValue,
     
@@ -25,12 +25,15 @@ module Reactive.Threepenny (
     ) where
 
 import Control.Applicative
+import Data.IORef
+import qualified Data.Map as Map
 
 import           Reactive.Threepenny.Memo       as Memo
 import qualified Reactive.Threepenny.PulseLatch as Prim
 
 type Pulse = Prim.Pulse
 type Latch = Prim.Latch
+type Map   = Map.Map
 
 {-----------------------------------------------------------------------------
     Types
@@ -53,15 +56,26 @@ newEvent = do
     return (E $ fromPure p, fire)
 
 
--- | Create a new event with some delayed initialization procedure.
+-- | Create a series of events with delayed initialization.
 --
--- The argument will be called when a handler is registered at the event.
--- This happens only once for each shared instance of the event.
-newEventDelayed :: Handler (Event a, Handler a) -> Event a
-newEventDelayed handler = E $ memoize $ do
-    (p, fire) <- Prim.newPulse
-    handler (E $ fromPure p, fire)
-    return p
+-- For each name, the initialization handler will be called
+-- exactly once when the event is first "brought to life",
+-- e.g. when an event handler is registered to it.
+newEventsNamed :: Ord name
+    => Handler (name, Event a, Handler a)   -- ^ Initialization procedure.
+    -> IO (name -> Event a)                 -- ^ Series of events.
+newEventsNamed init = do
+    eventsRef <- newIORef Map.empty
+    return $ \name -> E $ memoize $ do
+        events <- readIORef eventsRef
+        case Map.lookup name events of
+            Just p  -> return p
+            Nothing -> do
+                (p, fire) <- Prim.newPulse
+                writeIORef eventsRef $ Map.insert name p events
+                init (name, E $ fromPure p, fire)
+                return p
+
 
 -- | Register an event 'Handler' for an 'Event'.
 -- All registered handlers will be called whenever the event occurs.

From 5fb555071049f5ac3d362738ea7b0924eeac609f Mon Sep 17 00:00:00 2001
From: Heinrich Apfelmus <apfelmus@quantentunnel.de>
Date: Sun, 1 Sep 2013 16:58:18 +0200
Subject: [PATCH 25/41] Change type signature of stateful to use monad and
 hence fix starting time.

---
 src/Reactive/Threepenny.hs | 18 ++++++++++++------
 1 file changed, 12 insertions(+), 6 deletions(-)

diff --git a/src/Reactive/Threepenny.hs b/src/Reactive/Threepenny.hs
index aeb65d86..2cd8ab0e 100644
--- a/src/Reactive/Threepenny.hs
+++ b/src/Reactive/Threepenny.hs
@@ -124,18 +124,24 @@ filterJust e      = E $ liftMemo1 Prim.filterJustP    (unE e)
 unionWith f e1 e2 = E $ liftMemo2 (Prim.unionWithP f) (unE e1) (unE e2)
 
 apply  f x  = E $ liftMemo2 (\(l,_) p -> Prim.applyP l p) (unB f) (unE x)
-accumB a e  = B $ liftMemo1 (accumL a) (unE e)
+
+accumB :: a -> Event (a -> a) -> IO (Behavior a)
+accumB a e  = do
+        b <- accumL a =<< at (unE e)   -- ensure that starting time for behavior is now
+        return $ B $ fromPure b
     where
     accumL a p1 = do
         (l,p2) <- Prim.accumL a p1
         p3     <- Prim.mapP (const ()) p2
         return (l,p3)
 
-stepper :: a -> Event a -> Behavior a
+stepper :: a -> Event a -> IO (Behavior a)
 stepper a e = accumB a (const <$> e)
 
-accumE :: a -> Event (a -> a) -> Event a
-accumE a e = E $ liftMemo1 (fmap snd . Prim.accumL a) (unE e)
+accumE :: a -> Event (a -> a) -> IO (Event a)
+accumE a e = do
+    p <- fmap snd . Prim.accumL a =<< at (unE e)
+    return $ E $ fromPure p
 
 instance Functor Behavior where
     fmap f b = B $ memoize $ do
@@ -159,8 +165,8 @@ instance Applicative Behavior where
 test :: IO (Int -> IO ())
 test = do
     (e1,fire) <- newEvent
-    let e2 = accumE 0 ((+) <$> e1)
-    _ <- register e2 print
+    e2 <- accumE 0 $ (+) <$> e1
+    _  <- register e2 print
     
     return fire
 

From 68ea217c27f635c0438cd6b0dd4f5276b7a6255f Mon Sep 17 00:00:00 2001
From: Heinrich Apfelmus <apfelmus@quantentunnel.de>
Date: Sun, 1 Sep 2013 17:01:31 +0200
Subject: [PATCH 26/41] Add test whether recursion works.

---
 src/Reactive/Threepenny.hs            | 13 +++++++++++--
 src/Reactive/Threepenny/Memo.hs       |  2 +-
 src/Reactive/Threepenny/PulseLatch.hs | 18 +++++++++++++-----
 3 files changed, 25 insertions(+), 8 deletions(-)

diff --git a/src/Reactive/Threepenny.hs b/src/Reactive/Threepenny.hs
index 2cd8ab0e..df02c983 100644
--- a/src/Reactive/Threepenny.hs
+++ b/src/Reactive/Threepenny.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE RecursiveDo  #-}
 module Reactive.Threepenny (
     -- * Synopsis
     -- | Functional reactive programming.
@@ -169,7 +170,15 @@ test = do
     _  <- register e2 print
     
     return fire
-
-
+    
+test_recursion1 :: IO (IO ())
+test_recursion1 = mdo
+    (e1, fire) <- newEvent
+    b  <- accumB 0 $ (+1) <$ e2
+    let e2 :: Event Int
+        e2 = apply (const <$> b) e1
+    _  <- register e2 print
+    
+    return $ fire ()
 
 
diff --git a/src/Reactive/Threepenny/Memo.hs b/src/Reactive/Threepenny/Memo.hs
index bfff3598..9daa6fe8 100644
--- a/src/Reactive/Threepenny/Memo.hs
+++ b/src/Reactive/Threepenny/Memo.hs
@@ -27,7 +27,7 @@ at (Memoized r) = do
         Right a -> return a
         Left ma -> mdo
             writeIORef r $ Right a
-            a <- ma     -- FIXME: IO is not a good MonadFix instance
+            a <- ma    -- allow some recursion
             return a
 
 memoize :: IO a -> Memo a
diff --git a/src/Reactive/Threepenny/PulseLatch.hs b/src/Reactive/Threepenny/PulseLatch.hs
index fb0efcb7..8b5e1392 100644
--- a/src/Reactive/Threepenny/PulseLatch.hs
+++ b/src/Reactive/Threepenny/PulseLatch.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE RecordWildCards, RecursiveDo #-}
 module Reactive.Threepenny.PulseLatch (
     Pulse, newPulse, addHandler,
     neverP, mapP, filterJustP, unionWithP,
@@ -207,11 +207,19 @@ applyL l1 l2 = return $ Latch { readL = readL l1 <*> readL l2 }
 test :: IO (Int -> IO ())
 test = do
     (p1, fire) <- newPulse
-    p2 <- mapP (+) p1
+    p2     <- mapP (+) p1
     (l1,_) <- accumL 0 p2
-    l2 <- mapL const l1
-    p3 <- applyP l2 p1
+    l2     <- mapL const l1
+    p3     <- applyP l2 p1
     addHandler p3 print
-    
     return fire
 
+test_recursion1 :: IO (IO ())
+test_recursion1 = mdo
+    (p1, fire) <- newPulse
+    p2      <- applyP l2 p1
+    p3      <- mapP (const (+1)) p2
+    ~(l1,_) <- accumL (0::Int) p3
+    l2      <- mapL const l1
+    addHandler p2 print
+    return $ fire ()

From 710a4ee4e81d29e159428250350bee15da882106 Mon Sep 17 00:00:00 2001
From: Heinrich Apfelmus <apfelmus@quantentunnel.de>
Date: Sun, 1 Sep 2013 17:57:41 +0200
Subject: [PATCH 27/41] Make recursion work.

---
 src/Reactive/Threepenny.hs            | 92 ++++++++++++++++-----------
 src/Reactive/Threepenny/PulseLatch.hs | 14 ++--
 2 files changed, 61 insertions(+), 45 deletions(-)

diff --git a/src/Reactive/Threepenny.hs b/src/Reactive/Threepenny.hs
index df02c983..e2ce0e44 100644
--- a/src/Reactive/Threepenny.hs
+++ b/src/Reactive/Threepenny.hs
@@ -2,13 +2,6 @@
 module Reactive.Threepenny (
     -- * Synopsis
     -- | Functional reactive programming.
-    --
-    -- Note: Basic functionality should work,
-    -- but recursion does not work yet
-    -- and there may be some unexpected surprises
-    -- when attaching new behaviors amd events after some
-    -- events have already occured
-    -- ("dynamic event switching").
     
     -- * Types
     Handler, Event,
@@ -18,14 +11,18 @@ module Reactive.Threepenny (
     
     -- * Combinators
     never, filterJust, unionWith,
-    accumE, accumB, stepper, apply,
+    accumE, accumB, stepper, apply, (<@>), (<@),
     module Control.Applicative,
+
+    -- * Additional Notes
+    -- $recursion
     
     -- * Internal
     onChange,
     ) where
 
 import Control.Applicative
+import Control.Monad (void)
 import Data.IORef
 import qualified Data.Map as Map
 
@@ -39,8 +36,8 @@ type Map   = Map.Map
 {-----------------------------------------------------------------------------
     Types
 ------------------------------------------------------------------------------}
-newtype Event    a = E { unE :: Memo (Pulse a)           }
-newtype Behavior a = B { unB :: Memo (Latch a, Pulse ()) }
+newtype Event    a = E { unE :: Memo (Pulse a) }
+data    Behavior a = B { latch :: Latch a, changes :: Event () }
 
 {-----------------------------------------------------------------------------
     IO
@@ -100,16 +97,13 @@ register e h = do
 -- as behaviors may change continuously.
 -- Consequently, handlers should be idempotent.
 onChange :: Behavior a -> Handler a -> IO ()
-onChange b h = do
-    (l,p) <- at (unB b)
+onChange (B l e) h = void $ do
     -- This works because latches are updated before the handlers are being called.
-    Prim.addHandler p (\_ -> h =<< Prim.readLatch l)
+    register e (\_ -> h =<< Prim.readLatch l)
 
 -- | Read the current value of a 'Behavior'.
 currentValue :: Behavior a -> IO a
-currentValue b = do
-    (l, p) <- at (unB b)
-    Prim.readLatch l
+currentValue (B l _) = Prim.readLatch l
 
 
 {-----------------------------------------------------------------------------
@@ -124,17 +118,47 @@ never             = E $ fromPure Prim.neverP
 filterJust e      = E $ liftMemo1 Prim.filterJustP    (unE e)
 unionWith f e1 e2 = E $ liftMemo2 (Prim.unionWithP f) (unE e1) (unE e2)
 
-apply  f x  = E $ liftMemo2 (\(l,_) p -> Prim.applyP l p) (unB f) (unE x)
+{- $recursion
+Recursion in the 'IO' monad is possible, but somewhat limited.
+The main rule is that the sequence of IO actions must be known
+in advance, only the values may be recursive.
+
+Good:
+
+> mdo
+>     let e2 = apply (const <$> b) e1   -- applying a behavior is not an IO action
+>     b <- accumB $ (+1) <$ e2
+
+Bad:
+ 
+> mdo
+>     b <- accumB $ (+1) <$ e2          -- actions executed here could depend ...
+>     let e2 = apply (const <$> b) e1   -- ... on this value
+-}
+
+-- | Apply the current value of the behavior whenever the event occurs.
+--
+-- Note that behaviors created with 'stepper' or 'accumB' are not updated
+-- until shortly /after/ their creating event has occurred.
+-- This allows for recursive use.
+apply :: Behavior (a -> b) -> Event a -> Event b
+apply  f x        = E $ liftMemo1 (\p -> Prim.applyP (latch f) p) (unE x)
+
+infixl 4 <@>, <@
+
+-- | Infix synonym for 'apply', similar to '<$>'.
+(<@>) :: Behavior (a -> b) -> Event a -> Event b
+(<@>) = apply
+
+-- | Variant of 'apply' similar to '<$'
+(<@) :: Behavior a -> Event b -> Event a
+b <@ e = (const <$> b) <@> e
 
 accumB :: a -> Event (a -> a) -> IO (Behavior a)
-accumB a e  = do
-        b <- accumL a =<< at (unE e)   -- ensure that starting time for behavior is now
-        return $ B $ fromPure b
-    where
-    accumL a p1 = do
-        (l,p2) <- Prim.accumL a p1
-        p3     <- Prim.mapP (const ()) p2
-        return (l,p3)
+accumB a e = do
+    (l1,p1) <- Prim.accumL a =<< at (unE e)
+    p2      <- Prim.mapP (const ()) p1
+    return $ B l1 (E $ fromPure p2)
 
 stepper :: a -> Event a -> IO (Behavior a)
 stepper a e = accumB a (const <$> e)
@@ -145,20 +169,12 @@ accumE a e = do
     return $ E $ fromPure p
 
 instance Functor Behavior where
-    fmap f b = B $ memoize $ do
-        (l1,p1) <- at (unB b)
-        l2      <- Prim.mapL f l1
-        return (l2,p1)
+    fmap f ~(B l e) = B (Prim.mapL f l) e
 
 instance Applicative Behavior where
-    pure a  = B $ fromPure (Prim.pureL a,Prim.neverP)
-    f <*> x = B $ liftMemo2 applyB (unB f) (unB x)
-        where
-        applyB (l1,p1) (l2,p2) = do
-            p3 <- Prim.unionWithP const p1 p2
-            l3 <- Prim.applyL l1 l2
-            return (l3,p3)
-
+    pure a  = B (Prim.pureL a) never
+    ~(B lf ef) <*> ~(B lx ex) =
+        B (Prim.applyL lf lx) (unionWith const ef ex)
 
 {-----------------------------------------------------------------------------
     Test
@@ -174,9 +190,9 @@ test = do
 test_recursion1 :: IO (IO ())
 test_recursion1 = mdo
     (e1, fire) <- newEvent
-    b  <- accumB 0 $ (+1) <$ e2
     let e2 :: Event Int
         e2 = apply (const <$> b) e1
+    b  <- accumB 0 $ (+1) <$ e2
     _  <- register e2 print
     
     return $ fire ()
diff --git a/src/Reactive/Threepenny/PulseLatch.hs b/src/Reactive/Threepenny/PulseLatch.hs
index 8b5e1392..317bce57 100644
--- a/src/Reactive/Threepenny/PulseLatch.hs
+++ b/src/Reactive/Threepenny/PulseLatch.hs
@@ -175,7 +175,7 @@ accumL a p1 = do
     let l1 = Latch { readL = readIORef latch }
 
     -- calculate new pulse from old value
-    l2 <- mapL (flip ($)) l1
+    let l2 = mapL (flip ($)) l1
     p2 <- applyP l2 p1
 
     -- register handler to update latch
@@ -192,14 +192,14 @@ pureL a = Latch { readL = return a }
 -- | Map a function over latches.
 --
 -- Evaluated only when needed, result is not cached.
-mapL :: (a -> b) -> Latch a -> Build (Latch b)
-mapL f l = return $ Latch { readL = f <$> readL l } 
+mapL :: (a -> b) -> Latch a -> Latch b
+mapL f l = Latch { readL = f <$> readL l } 
 
 -- | Apply two current latch values
 --
 -- Evaluated only when needed, result is not cached.
-applyL :: Latch (a -> b) -> Latch a -> Build (Latch b)
-applyL l1 l2 = return $ Latch { readL = readL l1 <*> readL l2 }
+applyL :: Latch (a -> b) -> Latch a -> Latch b
+applyL l1 l2 = Latch { readL = readL l1 <*> readL l2 }
 
 {-----------------------------------------------------------------------------
     Test
@@ -209,7 +209,7 @@ test = do
     (p1, fire) <- newPulse
     p2     <- mapP (+) p1
     (l1,_) <- accumL 0 p2
-    l2     <- mapL const l1
+    let l2 =  mapL const l1
     p3     <- applyP l2 p1
     addHandler p3 print
     return fire
@@ -220,6 +220,6 @@ test_recursion1 = mdo
     p2      <- applyP l2 p1
     p3      <- mapP (const (+1)) p2
     ~(l1,_) <- accumL (0::Int) p3
-    l2      <- mapL const l1
+    let l2  =  mapL const l1
     addHandler p2 print
     return $ fire ()

From c7f2b25b0066425b08dac0059d9f17f85e5cc0c4 Mon Sep 17 00:00:00 2001
From: Heinrich Apfelmus <apfelmus@quantentunnel.de>
Date: Sun, 1 Sep 2013 18:28:27 +0200
Subject: [PATCH 28/41] Fix type exports.

---
 src/Graphics/UI/Threepenny/Canvas.hs | 2 +-
 src/Graphics/UI/Threepenny/Events.hs | 2 +-
 2 files changed, 2 insertions(+), 2 deletions(-)

diff --git a/src/Graphics/UI/Threepenny/Canvas.hs b/src/Graphics/UI/Threepenny/Canvas.hs
index 47c924e2..4e034c2d 100644
--- a/src/Graphics/UI/Threepenny/Canvas.hs
+++ b/src/Graphics/UI/Threepenny/Canvas.hs
@@ -4,7 +4,7 @@ module Graphics.UI.Threepenny.Canvas (
     
     -- * Documentation
     Canvas,
-    drawImage, clearCanvas,
+    Vector, drawImage, clearCanvas,
     ) where
 
 import Control.Event
diff --git a/src/Graphics/UI/Threepenny/Events.hs b/src/Graphics/UI/Threepenny/Events.hs
index f49e6400..bffc3f69 100644
--- a/src/Graphics/UI/Threepenny/Events.hs
+++ b/src/Graphics/UI/Threepenny/Events.hs
@@ -4,7 +4,7 @@ module Graphics.UI.Threepenny.Events (
     
     -- * Documentation
     click, mousemove, hover, blur, leave,
-    keyup, keydown,
+    KeyCode, keyup, keydown,
     ) where
 
 import Graphics.UI.Threepenny.Core

From 893a84f7a43d88d062a1a657af7ab44b36ee5b20 Mon Sep 17 00:00:00 2001
From: Heinrich Apfelmus <apfelmus@quantentunnel.de>
Date: Sun, 1 Sep 2013 18:31:08 +0200
Subject: [PATCH 29/41] Integrate FRP functionality into GUI modules. Add
 example 'CurrencyConverter'.

---
 README.md                             |  1 +
 src/CurrencyConverter.hs              | 52 +++++++++++++++++++++++++++
 src/Graphics/UI/Threepenny/Core.hs    | 15 +++++++-
 src/Graphics/UI/Threepenny/Events.hs  | 22 ++++++++++--
 src/Reactive/Threepenny.hs            |  5 +--
 src/Reactive/Threepenny/PulseLatch.hs | 10 +++++-
 6 files changed, 99 insertions(+), 6 deletions(-)
 create mode 100644 src/CurrencyConverter.hs

diff --git a/README.md b/README.md
index 320dad2b..0b5fb25b 100644
--- a/README.md
+++ b/README.md
@@ -27,6 +27,7 @@ This project was originally called Ji in its earliest iterations.
 * [BarTab.hs](https://github.com/HeinrichApfelmus/threepenny-gui/blob/master/src/BarTab.hs) - Dynamic creation of widgets.
 * [Buttons.hs](https://github.com/HeinrichApfelmus/threepenny-gui/blob/master/src/Buttons.hs) - Simple buttons to click on.
 * [Chat.hs](https://github.com/HeinrichApfelmus/threepenny-gui/blob/master/src/Chat.hs) - Multi-user chat.
+* [CurrencyConverter.hs](https://github.com/HeinrichApfelmus/threepenny-gui/blob/master/src/Buttons.hs) - Simple demonstration of two reactive input elements.
 * [DragNDropExample.hs](https://github.com/HeinrichApfelmus/threepenny-gui/blob/master/src/DragNDropExample.hs) - Simple drag'N'drop demo.
 * [DrumMachine.hs](https://github.com/HeinrichApfelmus/threepenny-gui/blob/master/src/DrumMachine.hs) - Specify rhythm by activating and deactivating checkboxes.
 * [MissingDollars.hs](https://github.com/HeinrichApfelmus/threepenny-gui/blob/master/src/MissingDollars.hs) - Text with configurable values.
diff --git a/src/CurrencyConverter.hs b/src/CurrencyConverter.hs
new file mode 100644
index 00000000..cd2353a6
--- /dev/null
+++ b/src/CurrencyConverter.hs
@@ -0,0 +1,52 @@
+{-----------------------------------------------------------------------------
+    threepenny-gui
+    
+    Example: Currency Converter
+------------------------------------------------------------------------------}
+{-# LANGUAGE RecursiveDo #-}
+
+import Control.Monad (void)
+import Data.Maybe
+import Text.Printf
+import Text.Read     (readMaybe)
+
+import qualified Graphics.UI.Threepenny as UI
+import Graphics.UI.Threepenny.Core
+
+{-----------------------------------------------------------------------------
+    Main
+------------------------------------------------------------------------------}
+main :: IO ()
+main = do
+    startGUI Config
+        { tpPort       = 10000
+        , tpCustomHTML = Nothing
+        , tpStatic     = ""
+        } setup
+
+setup :: Window -> IO ()
+setup window = void $ do
+    return window # set title "Currency Converter"
+
+    dollar <- UI.input
+    euro   <- UI.input
+    
+    getBody window #+ [
+            column [
+                grid [[string "Dollar:", element dollar]
+                     ,[string "Euro:"  , element euro  ]]
+            , string "Amounts update while typing."
+            ]]
+
+    euroIn   <- stepper "0" $ UI.valueChange euro
+    dollarIn <- stepper "0" $ UI.valueChange dollar
+    let
+        rate = 0.7 :: Double
+        withString f = maybe "-" (printf "%.2f") . fmap f . readMaybe
+    
+        dollarOut = withString (/ rate) <$> euroIn
+        euroOut   = withString (* rate) <$> dollarIn
+    
+    element euro   # sink value euroOut
+    element dollar # sink value dollarOut
+
diff --git a/src/Graphics/UI/Threepenny/Core.hs b/src/Graphics/UI/Threepenny/Core.hs
index fb10dc05..e3707586 100644
--- a/src/Graphics/UI/Threepenny/Core.hs
+++ b/src/Graphics/UI/Threepenny/Core.hs
@@ -35,7 +35,7 @@ module Graphics.UI.Threepenny.Core (
     -- | For a list of predefined attributes, see "Graphics.UI.Threepenny.Attributes".
     (#), (#.), element,
     Attr, WriteAttr, ReadAttr, ReadWriteAttr(..),
-    set, get, mkReadWriteAttr, mkWriteAttr, mkReadAttr,
+    set, sink, get, mkReadWriteAttr, mkWriteAttr, mkReadAttr,
     
     -- * JavaScript FFI
     -- | Direct interface to JavaScript in the browser window.
@@ -517,6 +517,19 @@ data ReadWriteAttr x i o = ReadWriteAttr
 set :: MonadIO m => ReadWriteAttr x i o -> i -> m x -> m x
 set attr i mx = do { x <- mx; liftIO (set' attr i x); return x; }
 
+-- | Set the value of an attribute to a 'Behavior', that is a time-varying value.
+--
+-- Note: For reasons of efficiency, the attribute is only
+-- updated when the value changes.
+sink :: ReadWriteAttr x i o -> Behavior i -> IO x -> IO x
+sink attr bi mx = do
+    x <- mx
+    do
+        i <- currentValue bi
+        set' attr i x
+        onChange bi $ \i -> set' attr i x  
+    return x
+
 -- | Get attribute value.
 get :: ReadWriteAttr x i o -> x -> IO o
 get = get'
diff --git a/src/Graphics/UI/Threepenny/Events.hs b/src/Graphics/UI/Threepenny/Events.hs
index bffc3f69..009a639c 100644
--- a/src/Graphics/UI/Threepenny/Events.hs
+++ b/src/Graphics/UI/Threepenny/Events.hs
@@ -1,16 +1,34 @@
 module Graphics.UI.Threepenny.Events (
     -- * Synopsis
-    -- | Common DOM events, for convenience.
+    -- | Events on DOM elements.
     
-    -- * Documentation
+    -- * Convenience events
+    valueChange, selectionChange,
+    
+    -- * Standard DOM events
     click, mousemove, hover, blur, leave,
     KeyCode, keyup, keydown,
     ) where
 
+import Graphics.UI.Threepenny.Attributes
 import Graphics.UI.Threepenny.Core
 
 silence = fmap (const ())
 
+{-----------------------------------------------------------------------------
+    Events
+------------------------------------------------------------------------------}
+-- | Event that occurs when the /user/ changes the value of the input element.
+valueChange :: Element -> Event String
+valueChange el = unsafeMapIO (const $ get value el) (domEvent "keydown" el)
+
+-- | Event that occurs when the /user/ changes the selection of a @<select>@ element.
+selectionChange :: Element -> Event (Maybe Int)
+selectionChange el = unsafeMapIO (const $ get selection el) (click el)
+
+{-----------------------------------------------------------------------------
+    DOM Events
+------------------------------------------------------------------------------}
 -- | Mouse click.
 click :: Element -> Event ()
 click = silence . domEvent "click"
diff --git a/src/Reactive/Threepenny.hs b/src/Reactive/Threepenny.hs
index e2ce0e44..474afebe 100644
--- a/src/Reactive/Threepenny.hs
+++ b/src/Reactive/Threepenny.hs
@@ -18,7 +18,7 @@ module Reactive.Threepenny (
     -- $recursion
     
     -- * Internal
-    onChange,
+    onChange, unsafeMapIO,
     ) where
 
 import Control.Applicative
@@ -83,7 +83,7 @@ newEventsNamed init = do
 -- 
 -- > do unregisterMyHandler <- register event myHandler
 --
--- FIXME: This does not currently work.
+-- FIXME: Unregistering event handlers does not work yet.
 register :: Event a -> Handler a -> IO (IO ())
 register e h = do
     p <- at (unE e)     -- evaluate the memoized action
@@ -112,6 +112,7 @@ currentValue (B l _) = Prim.readLatch l
 instance Functor Event where
     fmap f e = E $ liftMemo1 (Prim.mapP f) (unE e)
 
+unsafeMapIO f e   = E $ liftMemo1 (Prim.unsafeMapIOP f) (unE e)
 never             = E $ fromPure Prim.neverP
 
 -- | Keep only those event values that are of the form 'Just'.
diff --git a/src/Reactive/Threepenny/PulseLatch.hs b/src/Reactive/Threepenny/PulseLatch.hs
index 317bce57..57f8b87d 100644
--- a/src/Reactive/Threepenny/PulseLatch.hs
+++ b/src/Reactive/Threepenny/PulseLatch.hs
@@ -1,7 +1,7 @@
 {-# LANGUAGE RecordWildCards, RecursiveDo #-}
 module Reactive.Threepenny.PulseLatch (
     Pulse, newPulse, addHandler,
-    neverP, mapP, filterJustP, unionWithP,
+    neverP, mapP, filterJustP, unionWithP, unsafeMapIOP,
     
     Latch,
     pureL, mapL, applyL, accumL, applyP,
@@ -140,6 +140,14 @@ neverP = Pulse
 mapP :: (a -> b) -> Pulse a -> Build (Pulse b)
 mapP f p = (`dependOn` p) <$> cacheEval (return . fmap f =<< evalP p)
 
+-- | Map an IO function over pulses. Is only executed once.
+unsafeMapIOP :: (a -> IO b) -> Pulse a -> Build (Pulse b)
+unsafeMapIOP f p = (`dependOn` p) <$> cacheEval (traverse . fmap f =<< evalP p)
+    where
+    traverse :: Maybe (IO a) -> EvalP (Maybe a)
+    traverse Nothing  = return Nothing
+    traverse (Just m) = Just <$> lift m
+
 -- | Filter occurrences. Only keep those of the form 'Just'.
 filterJustP :: Pulse (Maybe a) -> Build (Pulse a)
 filterJustP p = (`dependOn` p) <$> cacheEval (return . join =<< evalP p)

From ed74258d72d452ed1bf165abf116d1962f965bc1 Mon Sep 17 00:00:00 2001
From: Heinrich Apfelmus <apfelmus@quantentunnel.de>
Date: Mon, 2 Sep 2013 18:09:56 +0200
Subject: [PATCH 30/41] Extensive documentation for 'Reactive.Threepenny'.

---
 src/Reactive/Threepenny.hs | 209 +++++++++++++++++++++++++++++++------
 1 file changed, 175 insertions(+), 34 deletions(-)

diff --git a/src/Reactive/Threepenny.hs b/src/Reactive/Threepenny.hs
index 474afebe..c1f19985 100644
--- a/src/Reactive/Threepenny.hs
+++ b/src/Reactive/Threepenny.hs
@@ -4,15 +4,31 @@ module Reactive.Threepenny (
     -- | Functional reactive programming.
     
     -- * Types
-    Handler, Event,
-    newEvent, newEventsNamed, register,
+    -- $intro
+    Event, Behavior,
     
-    Behavior, currentValue,
+    -- * IO
+    -- | Functions to connect events to the outside world.
+    Handler, newEvent, newEventsNamed, register,
+    currentValue,
     
-    -- * Combinators
-    never, filterJust, unionWith,
-    accumE, accumB, stepper, apply, (<@>), (<@),
+    -- * Core Combinators
+    -- | Minimal set of combinators for programming with 'Event' and 'Behavior'.
     module Control.Applicative,
+    never, filterJust, unionWith,
+    accumE, apply, stepper,
+    -- $classes
+    
+    -- * Derived Combinators
+    -- | Additional combinators that make programming
+    -- with 'Event' and 'Behavior' convenient.
+    -- ** Application
+    (<@>), (<@),
+    -- ** Filtering
+    filterE, filterApply, whenE, split,
+    -- ** Accumulation
+    -- $accumulation
+    accumB, mapAccum,
 
     -- * Additional Notes
     -- $recursion
@@ -36,7 +52,25 @@ type Map   = Map.Map
 {-----------------------------------------------------------------------------
     Types
 ------------------------------------------------------------------------------}
+{- $intro
+
+At its core, Functional Reactive Programming (FRP) is about two
+data types 'Event' and 'Behavior' and the various ways to combine them.
+
+-}
+
+{-| @Event a@ represents a stream of events as they occur in time.
+Semantically, you can think of @Event a@ as an infinite list of values
+that are tagged with their corresponding time of occurence,
+
+> type Event a = [(Time,a)]
+-}
 newtype Event    a = E { unE :: Memo (Pulse a) }
+
+{-| @Behavior a@ represents a value that varies in time. Think of it as
+
+> type Behavior a = Time -> a
+-}
 data    Behavior a = B { latch :: Latch a, changes :: Event () }
 
 {-----------------------------------------------------------------------------
@@ -107,63 +141,89 @@ currentValue (B l _) = Prim.readLatch l
 
 
 {-----------------------------------------------------------------------------
-    Combinators
+    Core Combinators
 ------------------------------------------------------------------------------}
 instance Functor Event where
     fmap f e = E $ liftMemo1 (Prim.mapP f) (unE e)
 
 unsafeMapIO f e   = E $ liftMemo1 (Prim.unsafeMapIOP f) (unE e)
-never             = E $ fromPure Prim.neverP
-
--- | Keep only those event values that are of the form 'Just'.
-filterJust e      = E $ liftMemo1 Prim.filterJustP    (unE e)
-unionWith f e1 e2 = E $ liftMemo2 (Prim.unionWithP f) (unE e1) (unE e2)
-
-{- $recursion
-Recursion in the 'IO' monad is possible, but somewhat limited.
-The main rule is that the sequence of IO actions must be known
-in advance, only the values may be recursive.
 
-Good:
+-- | Event that never occurs.
+-- Think of it as @never = []@.
+never :: Event a
+never = E $ fromPure Prim.neverP
 
-> mdo
->     let e2 = apply (const <$> b) e1   -- applying a behavior is not an IO action
->     b <- accumB $ (+1) <$ e2
-
-Bad:
- 
-> mdo
->     b <- accumB $ (+1) <$ e2          -- actions executed here could depend ...
->     let e2 = apply (const <$> b) e1   -- ... on this value
--}
+-- | Return all event occurrences that are 'Just' values, discard the rest.
+-- Think of it as
+-- 
+-- > filterJust es = [(time,a) | (time,Just a) <- es]
+filterJust e = E $ liftMemo1 Prim.filterJustP (unE e)
 
--- | Apply the current value of the behavior whenever the event occurs.
+-- | Merge two event streams of the same type.
+-- In case of simultaneous occurrences, the event values are combined
+-- with the binary function.
+-- Think of it as
 --
--- Note that behaviors created with 'stepper' or 'accumB' are not updated
--- until shortly /after/ their creating event has occurred.
--- This allows for recursive use.
+-- > unionWith f ((timex,x):xs) ((timey,y):ys)
+-- >    | timex == timey = (timex,f x y) : unionWith f xs ys
+-- >    | timex <  timey = (timex,x)     : unionWith f xs ((timey,y):ys)
+-- >    | timex >  timey = (timey,y)     : unionWith f ((timex,x):xs) ys
+unionWith :: (a -> a -> a) -> Event a -> Event a -> Event a
+unionWith f e1 e2 = E $ liftMemo2 (Prim.unionWithP f) (unE e1) (unE e2)
+
+-- | Apply a time-varying function to a stream of events.
+-- Think of it as
+-- 
+-- > apply bf ex = [(time, bf time x) | (time, x) <- ex]
 apply :: Behavior (a -> b) -> Event a -> Event b
 apply  f x        = E $ liftMemo1 (\p -> Prim.applyP (latch f) p) (unE x)
 
 infixl 4 <@>, <@
 
--- | Infix synonym for 'apply', similar to '<$>'.
+-- | Infix synonym for 'apply', similar to '<*>'.
 (<@>) :: Behavior (a -> b) -> Event a -> Event b
 (<@>) = apply
 
--- | Variant of 'apply' similar to '<$'
+-- | Variant of 'apply' similar to '<*'
 (<@) :: Behavior a -> Event b -> Event a
 b <@ e = (const <$> b) <@> e
 
+-- | The 'accumB' function is similar to a /strict/ left fold, 'foldl''.
+-- It starts with an initial value and combines it with incoming events.
+-- For example, think
+--
+-- > accumB "x" [(time1,(++"y")),(time2,(++"z"))]
+-- >    = stepper "x" [(time1,"xy"),(time2,"xyz")]
+-- 
+-- Note that the value of the behavior changes \"slightly after\"
+-- the events occur. This allows for recursive definitions.
 accumB :: a -> Event (a -> a) -> IO (Behavior a)
 accumB a e = do
     (l1,p1) <- Prim.accumL a =<< at (unE e)
     p2      <- Prim.mapP (const ()) p1
     return $ B l1 (E $ fromPure p2)
 
+
+-- | Construct a time-varying function from an initial value and 
+-- a stream of new values. Think of it as
+--
+-- > stepper x0 ex = return $ \time ->
+-- >     last (x0 : [x | (timex,x) <- ex, timex < time])
+-- 
+-- Note that the smaller-than-sign in the comparision @timex < time@ means 
+-- that the value of the behavior changes \"slightly after\"
+-- the event occurrences. This allows for recursive definitions.
 stepper :: a -> Event a -> IO (Behavior a)
 stepper a e = accumB a (const <$> e)
 
+-- | The 'accumE' function accumulates a stream of events.
+-- Example:
+--
+-- > accumE "x" [(time1,(++"y")),(time2,(++"z"))]
+-- >    = return [(time1,"xy"),(time2,"xyz")]
+--
+-- Note that the output events are simultaneous with the input events,
+-- there is no \"delay\" like in the case of 'accumB'.
 accumE :: a -> Event (a -> a) -> IO (Event a)
 accumE a e = do
     p <- fmap snd . Prim.accumL a =<< at (unE e)
@@ -177,6 +237,87 @@ instance Applicative Behavior where
     ~(B lf ef) <*> ~(B lx ex) =
         B (Prim.applyL lf lx) (unionWith const ef ex)
 
+{- $classes
+
+/Further combinators that Haddock can't document properly./
+
+> instance Applicative Behavior
+
+'Behavior' is an applicative functor. In particular, we have the following functions.
+
+> pure :: a -> Behavior a
+
+The constant time-varying value. Think of it as @pure x = \\time -> x@.
+
+> (<*>) :: Behavior (a -> b) -> Behavior a -> Behavior b
+
+Combine behaviors in applicative style.
+Think of it as @bf \<*\> bx = \\time -> bf time $ bx time@.
+
+-}
+
+{- $recursion
+
+Recursion in the 'IO' monad is possible, but somewhat limited.
+The main rule is that the sequence of IO actions must be known
+in advance, only the values may be recursive.
+
+Good:
+
+> mdo
+>     let e2 = apply (const <$> b) e1   -- applying a behavior is not an IO action
+>     b <- accumB $ (+1) <$ e2
+
+Bad:
+ 
+> mdo
+>     b <- accumB $ (+1) <$ e2          -- actions executed here could depend ...
+>     let e2 = apply (const <$> b) e1   -- ... on this value
+
+-}
+
+{-----------------------------------------------------------------------------
+    Derived Combinators
+------------------------------------------------------------------------------}
+-- | Return all event occurrences that fulfill the predicate, discard the rest.
+filterE :: (a -> Bool) -> Event a -> Event a
+filterE p = filterJust . fmap (\a -> if p a then Just a else Nothing)
+
+-- | Return all event occurrences that fulfill the time-varying predicate,
+-- discard the rest. Generalization of 'filterE'.
+filterApply :: Behavior (a -> Bool) -> Event a -> Event a
+filterApply bp = fmap snd . filterE fst . apply ((\p a -> (p a,a)) <$> bp)
+
+-- | Return event occurrences only when the behavior is 'True'.
+-- Variant of 'filterApply'.
+whenE :: Behavior Bool -> Event a -> Event a
+whenE bf = filterApply (const <$> bf)
+
+-- | Split event occurrences according to a tag.
+-- The 'Left' values go into the left component while the 'Right' values
+-- go into the right component of the result.
+split :: Event (Either a b) -> (Event a, Event b)
+split e = (filterJust $ fromLeft <$> e, filterJust $ fromRight <$> e)
+    where
+    fromLeft  (Left  a) = Just a
+    fromLeft  (Right b) = Nothing
+    fromRight (Left  a) = Nothing
+    fromRight (Right b) = Just b
+
+{- $accumulation
+
+Note: All accumulation functions are strict in the accumulated value!
+acc -> (x,acc) is the order used by 'unfoldr' and 'State'.
+
+-}
+
+-- | Efficient combination of 'accumE' and 'accumB'.
+mapAccum :: acc -> Event (acc -> (x,acc)) -> IO (Event x, Behavior acc)
+mapAccum acc ef = do
+    e <- accumE (undefined,acc) ((. snd) <$> ef)
+    b <- stepper acc (snd <$> e)
+    return (fst <$> e, b)
+
 {-----------------------------------------------------------------------------
     Test
 ------------------------------------------------------------------------------}

From b047ad7ec4f8c2c62ffba869da03b9a4d97736dd Mon Sep 17 00:00:00 2001
From: Heinrich Apfelmus <apfelmus@quantentunnel.de>
Date: Mon, 2 Sep 2013 18:14:14 +0200
Subject: [PATCH 31/41] Fix 'DrumMachine' example.

---
 src/DrumMachine.hs | 7 +++----
 1 file changed, 3 insertions(+), 4 deletions(-)

diff --git a/src/DrumMachine.hs b/src/DrumMachine.hs
index 4b5bdc0a..eba37f37 100644
--- a/src/DrumMachine.hs
+++ b/src/DrumMachine.hs
@@ -55,10 +55,9 @@ setup w = void $ do
                       ,[UI.string "Beat:", element elTick]]
     getBody w #+ [UI.div #. "wrap" #+ (status : map element elInstruments)]
     
-    timer   <- UI.timer # set UI.interval (bpm2ms defaultBpm)
-    let
-        eBeat :: Event Int
-        eBeat = accumE 0 $ (\beat -> (beat + 1) `mod` (beats * bars)) <$ UI.tick timer
+    timer <- UI.timer # set UI.interval (bpm2ms defaultBpm)
+    eBeat <- accumE (0::Int) $
+        (\beat -> (beat + 1) `mod` (beats * bars)) <$ UI.tick timer
     _ <- register eBeat $ \beat -> do
         -- display beat count
         element elTick # set text (show $ beat + 1)

From 5c14d4a6e558e7561246f24b995da74b19da2c34 Mon Sep 17 00:00:00 2001
From: Heinrich Apfelmus <apfelmus@quantentunnel.de>
Date: Mon, 2 Sep 2013 18:16:07 +0200
Subject: [PATCH 32/41] Remove unused modules from '.cabal' file.

---
 src/Control/Event.hs                 | 111 ---------------------------
 src/Control/Monad/Extra.hs           |  30 --------
 src/Control/Monad/IO.hs              |   8 --
 src/Graphics/UI/Threepenny/Canvas.hs |   1 -
 src/MissingDollars.hs                |   1 -
 threepenny-gui.cabal                 |   3 -
 6 files changed, 154 deletions(-)
 delete mode 100644 src/Control/Event.hs
 delete mode 100644 src/Control/Monad/Extra.hs
 delete mode 100644 src/Control/Monad/IO.hs

diff --git a/src/Control/Event.hs b/src/Control/Event.hs
deleted file mode 100644
index 0d53f34f..00000000
--- a/src/Control/Event.hs
+++ /dev/null
@@ -1,111 +0,0 @@
-module Control.Event (
-    -- * Synopsis
-    -- | Event-driven programming in the imperative style.
-        
-    -- * Documentation
-    Handler, Event(..),
-    mapIO, filterIO, filterJust,
-    newEvent, newEventsTagged
-    ) where
-
-
-import Data.IORef
-import qualified Data.Unique -- ordinary uniques here, because they are Ord
-
-import qualified Data.Map as Map
-
-type Map = Map.Map
-
-{-----------------------------------------------------------------------------
-    Types
-------------------------------------------------------------------------------}
--- | An /event handler/ is a function that takes an
--- /event value/ and performs some computation.
-type Handler a = a -> IO ()
-
-
--- | An /event/ is a facility for registering
--- event handlers. These will be called whenever the event occurs.
--- 
--- When registering an event handler, you will also be given an action
--- that unregisters this handler again.
--- 
--- > do unregisterMyHandler <- register event myHandler
---
-newtype Event a = Event { register :: Handler a -> IO (IO ()) }
-
-{-----------------------------------------------------------------------------
-    Combinators
-------------------------------------------------------------------------------}
-instance Functor Event where
-    fmap f = mapIO (return . f)
-
--- | Map the event value with an 'IO' action.
-mapIO :: (a -> IO b) -> Event a -> Event b
-mapIO f e = Event $ \h -> register e $ \x -> f x >>= h 
-
--- | Filter event values that don't return 'True'.
-filterIO :: (a -> IO Bool) -> Event a -> Event a
-filterIO f e = Event $ \h ->
-    register e $ \x -> f x >>= \b -> if b then h x else return ()
-
--- | Keep only those event values that are of the form 'Just'.
-filterJust :: Event (Maybe a) -> Event a
-filterJust e = Event $ \g -> register e (maybe (return ()) g)
-
-
-{-----------------------------------------------------------------------------
-    Construction
-------------------------------------------------------------------------------}
--- | Build a facility to register and unregister event handlers.
--- Also yields a function that takes an event handler and runs all the registered
--- handlers.
---
--- Example:
---
--- > do
--- >     (event, fire) <- newEvent
--- >     register event (putStrLn)
--- >     fire "Hello!"
-newEvent :: IO (Event a, a -> IO ())
-newEvent = do
-    handlers <- newIORef Map.empty
-    let register handler = do
-            key <- Data.Unique.newUnique
-            atomicModifyIORef_ handlers $ Map.insert key handler
-            return $ atomicModifyIORef_ handlers $ Map.delete key
-        runHandlers a =
-            mapM_ ($ a) . map snd . Map.toList =<< readIORef handlers
-    return (Event register, runHandlers)
-
--- | Build several 'Event's from case analysis on a tag.
--- Generalization of 'newEvent'.
-newEventsTagged :: Ord tag => IO (tag -> Event a, (tag, a) -> IO ())
-newEventsTagged = do
-    handlersRef <- newIORef Map.empty       -- :: Map key (Map Unique (Handler a))
-
-    let register tag handler = do
-            -- new identifier for this handler
-            uid <- Data.Unique.newUnique
-            -- add handler to map at  key
-            atomicModifyIORef_ handlersRef $
-                Map.alter (Just . Map.insert uid handler . maybe Map.empty id) tag
-            -- remove handler from map at  key
-            return $ atomicModifyIORef_ handlersRef $
-                Map.adjust (Map.delete uid) tag
-
-    let runHandlers (tag,a) = do
-            handlers <- readIORef handlersRef
-            case Map.lookup tag handlers of
-                Just hs -> mapM_ ($ a) (Map.elems hs)
-                Nothing -> return ()
-
-    return (\tag -> Event (register tag), runHandlers)
-            
-{-----------------------------------------------------------------------------
-    Utilities
-------------------------------------------------------------------------------}
-atomicModifyIORef_ ref f = atomicModifyIORef ref $ \x -> (f x, ())
-
-
-
diff --git a/src/Control/Monad/Extra.hs b/src/Control/Monad/Extra.hs
deleted file mode 100644
index ef78f98b..00000000
--- a/src/Control/Monad/Extra.hs
+++ /dev/null
@@ -1,30 +0,0 @@
--- | Extra utilities for monads.
-
-module Control.Monad.Extra where
-
-import Data.Maybe
-
--- | Ignore the given action's return.
-ig :: (Monad m) => m a -> m ()
-ig m = m >> return ()
-
--- | A non-operator version of (=<<).
-bind :: (Monad m) => (a -> m b) -> m a -> m b
-bind = flip (>>=)
-
--- | When the value is Just, run the action.
-whenJust :: Monad m => Maybe a -> (a -> m ()) -> m ()
-whenJust (Just a) m = m a
-whenJust Nothing  _ = return ()
-
--- | Wrap up a functor in a Maybe.
-just :: Functor m => m a -> m (Maybe a)
-just = fmap Just
-
--- | Flip mapMaybe.
-forMaybe :: [a] -> (a -> Maybe b) -> [b]
-forMaybe = flip mapMaybe
-
--- | Monadic version of maybe.
-maybeM :: (Monad m) => a -> (a1 -> m a) -> Maybe a1 -> m a
-maybeM nil cons a = maybe (return nil) cons a
diff --git a/src/Control/Monad/IO.hs b/src/Control/Monad/IO.hs
deleted file mode 100644
index 26a50113..00000000
--- a/src/Control/Monad/IO.hs
+++ /dev/null
@@ -1,8 +0,0 @@
-{-# OPTIONS -Wall #-}
-
-module Control.Monad.IO where
-
-import Control.Monad.IO.Class
-
-io :: MonadIO m => IO a -> m a
-io = liftIO
diff --git a/src/Graphics/UI/Threepenny/Canvas.hs b/src/Graphics/UI/Threepenny/Canvas.hs
index 4e034c2d..951443d4 100644
--- a/src/Graphics/UI/Threepenny/Canvas.hs
+++ b/src/Graphics/UI/Threepenny/Canvas.hs
@@ -7,7 +7,6 @@ module Graphics.UI.Threepenny.Canvas (
     Vector, drawImage, clearCanvas,
     ) where
 
-import Control.Event
 import Graphics.UI.Threepenny.Core
 import qualified Graphics.UI.Threepenny.Internal.Core as Core
 import qualified Graphics.UI.Threepenny.Internal.Types as Core
diff --git a/src/MissingDollars.hs b/src/MissingDollars.hs
index 5263c6fe..5c8ddb76 100644
--- a/src/MissingDollars.hs
+++ b/src/MissingDollars.hs
@@ -1,7 +1,6 @@
 {-# LANGUAGE CPP, PackageImports #-}
 
 import Control.Monad
-import Control.Monad.Extra
 import Safe
 
 #ifdef CABAL
diff --git a/threepenny-gui.cabal b/threepenny-gui.cabal
index 30410bfa..378082c3 100644
--- a/threepenny-gui.cabal
+++ b/threepenny-gui.cabal
@@ -75,9 +75,6 @@ Library
                     ,Graphics.UI.Threepenny.Timer
   Other-modules:
                      Control.Concurrent.Chan.Extra
-                    ,Control.Event
-                    ,Control.Monad.Extra
-                    ,Control.Monad.IO
                     ,Control.Concurrent.Delay
                     ,Graphics.UI.Threepenny.Internal.Core
                     ,Graphics.UI.Threepenny.Internal.Resources

From 001b052732bf9a2bf821bb6814d801f70325cf50 Mon Sep 17 00:00:00 2001
From: Daniel Mlot <duplode_1@yahoo.com.br>
Date: Tue, 3 Sep 2013 23:21:40 -0300
Subject: [PATCH 33/41] Adjusting a 'Hashable' instance for compatibility with
 'hashable-1.2.*'.

---
 src/Reactive/Threepenny/PulseLatch.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/Reactive/Threepenny/PulseLatch.hs b/src/Reactive/Threepenny/PulseLatch.hs
index 57f8b87d..6478ad26 100644
--- a/src/Reactive/Threepenny/PulseLatch.hs
+++ b/src/Reactive/Threepenny/PulseLatch.hs
@@ -42,7 +42,7 @@ runEvalP pulses m = do
 type Handler  = EvalP (IO ())
 data Priority = DoLatch | DoIO deriving (Eq,Show,Ord,Enum)
 
-instance Hashable Priority where hash = fromEnum
+instance Hashable Priority where hashWithSalt _ = fromEnum
 
 data Pulse a = Pulse
     { addHandlerP :: ((Unique, Priority), Handler) -> Build ()

From a3bdbe4efb8ee0e8f721ccc4f45601d2ce21af29 Mon Sep 17 00:00:00 2001
From: Heinrich Apfelmus <apfelmus@quantentunnel.de>
Date: Wed, 4 Sep 2013 18:41:18 +0200
Subject: [PATCH 34/41] Add 'unions' combinator and 'concatenate' helper
 function.

---
 src/Reactive/Threepenny.hs | 13 +++++++++++++
 1 file changed, 13 insertions(+)

diff --git a/src/Reactive/Threepenny.hs b/src/Reactive/Threepenny.hs
index c1f19985..343d6ebc 100644
--- a/src/Reactive/Threepenny.hs
+++ b/src/Reactive/Threepenny.hs
@@ -26,6 +26,8 @@ module Reactive.Threepenny (
     (<@>), (<@),
     -- ** Filtering
     filterE, filterApply, whenE, split,
+    -- ** Union
+    unions, concatenate,
     -- ** Accumulation
     -- $accumulation
     accumB, mapAccum,
@@ -304,6 +306,17 @@ split e = (filterJust $ fromLeft <$> e, filterJust $ fromRight <$> e)
     fromRight (Left  a) = Nothing
     fromRight (Right b) = Just b
 
+-- | Collect simultaneous event occurrences in a list.
+unions :: [Event a] -> Event [a]
+unions = foldr (unionWith (++)) never . map (fmap (:[]))
+
+-- | Apply a list of functions in succession.
+-- Useful in conjunction with 'unions'.
+--
+-- > concatenate [f,g,h] = f . g . h 
+concatenate :: [a -> a] -> (a -> a)
+concatenate = foldr (.) id
+
 {- $accumulation
 
 Note: All accumulation functions are strict in the accumulated value!

From 26fcf13cf3497e54a84028332121be717a5f5658 Mon Sep 17 00:00:00 2001
From: Heinrich Apfelmus <apfelmus@quantentunnel.de>
Date: Wed, 4 Sep 2013 19:29:10 +0200
Subject: [PATCH 35/41] Add example to documentation. Fix #36.

---
 src/Graphics/UI/Threepenny.hs      | 88 ++++++++++++++++++++++++++++++
 src/Graphics/UI/Threepenny/Core.hs | 42 +++-----------
 2 files changed, 97 insertions(+), 33 deletions(-)

diff --git a/src/Graphics/UI/Threepenny.hs b/src/Graphics/UI/Threepenny.hs
index 7bf027d4..bd0808d2 100644
--- a/src/Graphics/UI/Threepenny.hs
+++ b/src/Graphics/UI/Threepenny.hs
@@ -1,4 +1,11 @@
 module Graphics.UI.Threepenny (
+    -- * Introduction
+    -- $intro
+
+    -- * Example
+    -- $example
+    
+    -- * Modules
     module Graphics.UI.Threepenny.Attributes,
     module Graphics.UI.Threepenny.Core,
     module Graphics.UI.Threepenny.Canvas,
@@ -17,3 +24,84 @@ import Graphics.UI.Threepenny.Elements
 import Graphics.UI.Threepenny.Events
 import Graphics.UI.Threepenny.JQuery
 import Graphics.UI.Threepenny.Timer
+
+{- $intro
+
+Welcome to the Threepenny library for graphical user interfaces.
+
+A program written with Threepenny is essentially a small web server
+that displays the user interface as a web page to any browser that connects to it.
+
+For an introduction, see the example below.
+The module "Graphics.UI.Threepenny.Core" contains the main functions.
+
+This project was originally called Ji.
+
+-}
+
+
+{- $example
+
+The following example should help to get you started with Threepenny.
+(The lines of code below are meant to be concatenated into a single file.)
+
+> module Main where
+
+First, we have to import the library.
+It is a good idea to import the core module verbatim
+and import all other functions with a mandatory @UI@ prefix.
+
+> import qualified Graphics.UI.Threepenny       as UI
+> import           Graphics.UI.Threepenny.Core
+
+We begin by starting a server on port @10000@ using the 'startGUI' function.
+Additional static content is served from the @../wwwroot@ directory.
+
+> main :: IO ()
+> main = do
+>     startGUI Config
+>         { tpPort       = 10000
+>         , tpCustomHTML = Nothing
+>         , tpStatic     = "../wwwroot"
+>         } setup
+
+Whenever a browser connects to the server,
+the following function will be executed to start the GUI interaction.
+It builds the initial HTML page.
+
+> setup :: Window -> IO ()
+> setup window = do
+
+First, set the title of the HTML document
+
+>     return window # set UI.title "Hello World!"
+
+Then create a button element
+
+>     button <- UI.button # set UI.text "Click me!s"
+
+DOM elements can be accessed much in the same way they are
+accessed from JavaScript; they can be searched, updated, moved and
+inspected. In the line above, we set the 'text' contents.
+
+To actually display the button, we have to attach it to the body of the HTML element.
+The '#+' combinator allows you to nest elements quickly
+in the style of a HTML combinator library.
+
+>     getBody window #+ [element button]
+
+Finally, we register an event handler for the 'click' event,
+which occurs whenever the user clicks on the button.
+When that happens, we change the text of the button.
+
+>     on UI.click button $ const $ do
+>         element button # set UI.text "I have been clicked!"
+
+That's it for a first example!
+
+The libary comes with a
+<https://github.com/HeinrichApfelmus/threepenny-gui/tree/master/src plethora of additional example code>.
+
+
+-}
+
diff --git a/src/Graphics/UI/Threepenny/Core.hs b/src/Graphics/UI/Threepenny/Core.hs
index e3707586..b05399a9 100644
--- a/src/Graphics/UI/Threepenny/Core.hs
+++ b/src/Graphics/UI/Threepenny/Core.hs
@@ -1,7 +1,7 @@
 {-# LANGUAGE DeriveDataTypeable, RecordWildCards #-}
 module Graphics.UI.Threepenny.Core (
-    -- * Guide
-    -- $guide
+    -- * Synopsis
+    -- | Core functionality of the Threepenny GUI library.
     
     -- * Server
     -- $server
@@ -70,37 +70,6 @@ import Graphics.UI.Threepenny.Internal.Core
 import qualified Graphics.UI.Threepenny.Internal.Types as Core
 import Graphics.UI.Threepenny.Internal.Types (Window, Config, EventData, Session(..))
 
-{-----------------------------------------------------------------------------
-    Guide
-------------------------------------------------------------------------------}
-{- $guide
-
-Threepenny runs a small web server that displays the user interface
-as a web page to any browser that connects to it.
-To start the web server, use the 'startGUI' function.
-
-Creating of DOM elements is easy,
-the '(#+)' combinator allows a style similar to HTML combinator libraries.
-
-Existing DOM elements can be accessed much in the same way they are
-accessed from JavaScript; they can be searched, updated, moved and
-inspected. Events can be bound to DOM elements and handled.
-
-
-Applications written in Threepenny are multithreaded. Each client (user)
-has a separate thread which runs with no awareness of the asynchronous
-protocol below. Each session should only be accessed from one
-thread. There is not yet any clever architecture for accessing the
-(single threaded) web browser from multi-threaded Haskell. That's
-my recommendation. You can choose to ignore it, but don't blame me
-when you run an element search and you get a click event as a
-result.
-
-This project was originally called Ji.
-
--}
-
-
 {-----------------------------------------------------------------------------
     Server
 ------------------------------------------------------------------------------}
@@ -111,6 +80,13 @@ Then, visit the URL <http://localhost:10000/> in your browser
 (assuming that you have set the port number to @tpPort=10000@
 in the server configuration).
 
+The server is multithreaded,
+a separate thread is used to communicate with a single browser 'Window'.
+However, each window should only be accessed from a single thread,
+otherwise the behavior will be undefined,
+i.e. you could run an element search and get a click event as a result
+if you don't access each window in a single-threaded fashion.
+
 -}
 
 -- | Start server for GUI sessions.

From 3e02e008ab34b16264e5aaabd7110d143077db0d Mon Sep 17 00:00:00 2001
From: Daniel Mlot <duplode_1@yahoo.com.br>
Date: Thu, 5 Sep 2013 01:30:50 -0300
Subject: [PATCH 36/41] Add a 'checkedChange' convenience event.

---
 src/Graphics/UI/Threepenny/Events.hs | 7 ++++++-
 1 file changed, 6 insertions(+), 1 deletion(-)

diff --git a/src/Graphics/UI/Threepenny/Events.hs b/src/Graphics/UI/Threepenny/Events.hs
index 009a639c..4b9e461a 100644
--- a/src/Graphics/UI/Threepenny/Events.hs
+++ b/src/Graphics/UI/Threepenny/Events.hs
@@ -3,7 +3,7 @@ module Graphics.UI.Threepenny.Events (
     -- | Events on DOM elements.
     
     -- * Convenience events
-    valueChange, selectionChange,
+    valueChange, selectionChange, checkedChange,
     
     -- * Standard DOM events
     click, mousemove, hover, blur, leave,
@@ -26,6 +26,11 @@ valueChange el = unsafeMapIO (const $ get value el) (domEvent "keydown" el)
 selectionChange :: Element -> Event (Maybe Int)
 selectionChange el = unsafeMapIO (const $ get selection el) (click el)
 
+-- | Event that occurs when the /user/ changes the checked status of an input
+-- element of type checkbox.
+checkedChange :: Element -> Event Bool
+checkedChange el = unsafeMapIO (const $ get checked el) (click el)
+
 {-----------------------------------------------------------------------------
     DOM Events
 ------------------------------------------------------------------------------}

From 8a1fd2629a2ae888fd233d6908fb6b9c7ea9533f Mon Sep 17 00:00:00 2001
From: Heinrich Apfelmus <apfelmus@quantentunnel.de>
Date: Fri, 6 Sep 2013 16:19:41 +0200
Subject: [PATCH 37/41] Add header 'Cache-control:no-cache' to prevent caching
 of CSS and other static files. Fix #42

---
 src/Graphics/UI/Threepenny/Internal/Core.hs | 24 +++++++++++++--------
 1 file changed, 15 insertions(+), 9 deletions(-)

diff --git a/src/Graphics/UI/Threepenny/Internal/Core.hs b/src/Graphics/UI/Threepenny/Internal/Core.hs
index afe240b1..70ae7494 100644
--- a/src/Graphics/UI/Threepenny/Internal/Core.hs
+++ b/src/Graphics/UI/Threepenny/Internal/Core.hs
@@ -385,16 +385,22 @@ type Routes = [(ByteString, Snap ())]
 
 routeResources :: Maybe FilePath -> FilePath -> ServerState -> Routes
 routeResources customHTML staticDir server =
-    [("/static"                    , serveDirectory staticDir)
-    ,("/"                          , root)
-    ,("/driver/threepenny-gui.js"  , writeText jsDriverCode )
-    ,("/driver/threepenny-gui.css" , writeText cssDriverCode)
-    ,("/file/:name"                ,
-        withFilepath (sFiles server) (flip serveFileAs))
-    ,("/dir/:name"                 ,
-        withFilepath (sDirs  server) (\path _ -> serveDirectory path))
-    ]
+    fixHandlers noCache $
+        [("/static"                    , serveDirectory staticDir)
+        ,("/"                          , root)
+        ,("/driver/threepenny-gui.js"  , writeText jsDriverCode )
+        ,("/driver/threepenny-gui.css" , writeText cssDriverCode)
+        ,("/file/:name"                ,
+            withFilepath (sFiles server) (flip serveFileAs))
+        ,("/dir/:name"                 ,
+            withFilepath (sDirs  server) (\path _ -> serveDirectory path))
+        ]
     where
+    fixHandlers f routes = [(a,f b) | (a,b) <- routes]
+    noCache h = do
+        modifyResponse $ setHeader "Cache-Control" "no-cache"
+        h
+    
     root = case customHTML of
         Just file -> serveFile (staticDir </> file)
         Nothing   -> writeText defaultHtmlFile

From 5bc9b86939a43eca6067343144e3fa07b4f0f123 Mon Sep 17 00:00:00 2001
From: Heinrich Apfelmus <apfelmus@quantentunnel.de>
Date: Fri, 6 Sep 2013 16:48:53 +0200
Subject: [PATCH 38/41] Make logging method customizable. Removes unsightly
 error messages from the console when running a Threepenny application. #26

---
 src/BarTab.hs                                |  5 ++--
 src/Buttons.hs                               |  5 ++--
 src/Chat.hs                                  |  4 ++--
 src/CurrencyConverter.hs                     |  7 +-----
 src/DragNDropExample.hs                      |  5 ++--
 src/Drawing.hs                               |  7 +-----
 src/DrumMachine.hs                           |  5 ++--
 src/Graphics/UI/Threepenny/Core.hs           |  5 ++--
 src/Graphics/UI/Threepenny/Internal/Core.hs  | 25 ++++++++++++--------
 src/Graphics/UI/Threepenny/Internal/Types.hs | 24 +++++++++++++++----
 src/InputElements.hs                         |  5 ++--
 src/MissingDollars.hs                        |  5 ++--
 src/Mouse.hs                                 |  7 +-----
 src/UseWords.hs                              |  5 ++--
 src/VideoAnnotate.hs                         |  5 ++--
 15 files changed, 58 insertions(+), 61 deletions(-)

diff --git a/src/BarTab.hs b/src/BarTab.hs
index 0952d27e..67dd9b95 100644
--- a/src/BarTab.hs
+++ b/src/BarTab.hs
@@ -20,10 +20,9 @@ import Graphics.UI.Threepenny.Core
 main :: IO ()
 main = do
     static <- getStaticDir
-    startGUI Config
+    startGUI defaultConfig
         { tpPort       = 10000
-        , tpCustomHTML = Nothing
-        , tpStatic     = static
+        , tpStatic     = Just static
         } setup
 
 setup :: Window -> IO ()
diff --git a/src/Buttons.hs b/src/Buttons.hs
index 2f0be24c..2671f8a0 100644
--- a/src/Buttons.hs
+++ b/src/Buttons.hs
@@ -19,10 +19,9 @@ import Paths
 main :: IO ()
 main = do
     static <- getStaticDir
-    startGUI Config
+    startGUI defaultConfig
         { tpPort       = 10000
-        , tpCustomHTML = Nothing
-        , tpStatic     = static
+        , tpStatic     = Just static
         } setup
 
 setup :: Window -> IO ()
diff --git a/src/Chat.hs b/src/Chat.hs
index 906304d5..0c278dfd 100644
--- a/src/Chat.hs
+++ b/src/Chat.hs
@@ -31,10 +31,10 @@ main :: IO ()
 main = do
     static   <- getStaticDir
     messages <- Chan.newChan
-    startGUI Config
+    startGUI defaultConfig
         { tpPort       = 10000
         , tpCustomHTML = Just "chat.html"
-        , tpStatic     = static
+        , tpStatic     = Just static
         } $ setup messages
 
 type Message = (UTCTime, String, String)
diff --git a/src/CurrencyConverter.hs b/src/CurrencyConverter.hs
index cd2353a6..d11e92b9 100644
--- a/src/CurrencyConverter.hs
+++ b/src/CurrencyConverter.hs
@@ -17,12 +17,7 @@ import Graphics.UI.Threepenny.Core
     Main
 ------------------------------------------------------------------------------}
 main :: IO ()
-main = do
-    startGUI Config
-        { tpPort       = 10000
-        , tpCustomHTML = Nothing
-        , tpStatic     = ""
-        } setup
+main = startGUI defaultConfig { tpPort = 10000 } setup
 
 setup :: Window -> IO ()
 setup window = void $ do
diff --git a/src/DragNDropExample.hs b/src/DragNDropExample.hs
index f856345e..86c51080 100644
--- a/src/DragNDropExample.hs
+++ b/src/DragNDropExample.hs
@@ -20,10 +20,9 @@ import Paths
 main :: IO ()
 main = do
     static <- getStaticDir
-    startGUI Config
+    startGUI defaultConfig
         { tpPort       = 10000
-        , tpCustomHTML = Nothing
-        , tpStatic     = static
+        , tpStatic     = Just static
         } setup
 
 setup :: Window -> IO ()
diff --git a/src/Drawing.hs b/src/Drawing.hs
index 85df3397..e5546c1e 100644
--- a/src/Drawing.hs
+++ b/src/Drawing.hs
@@ -17,12 +17,7 @@ import System.FilePath
     Main
 ------------------------------------------------------------------------------}
 main :: IO ()
-main = do
-    startGUI Config
-        { tpPort       = 10000
-        , tpCustomHTML = Nothing
-        , tpStatic     = ""
-        } setup
+main = startGUI defaultConfig { tpPort = 10000 } setup
 
 setup :: Window -> IO ()
 setup window = do
diff --git a/src/DrumMachine.hs b/src/DrumMachine.hs
index eba37f37..4f030606 100644
--- a/src/DrumMachine.hs
+++ b/src/DrumMachine.hs
@@ -38,10 +38,9 @@ loadInstrumentSample w name = do
 main :: IO ()
 main = do
     static <- getStaticDir
-    startGUI Config
+    startGUI defaultConfig
         { tpPort       = 10000
-        , tpCustomHTML = Nothing
-        , tpStatic     = static
+        , tpStatic     = Just static
         } setup
 
 setup :: Window -> IO ()
diff --git a/src/Graphics/UI/Threepenny/Core.hs b/src/Graphics/UI/Threepenny/Core.hs
index b05399a9..413e0d12 100644
--- a/src/Graphics/UI/Threepenny/Core.hs
+++ b/src/Graphics/UI/Threepenny/Core.hs
@@ -5,7 +5,7 @@ module Graphics.UI.Threepenny.Core (
     
     -- * Server
     -- $server
-    Config(..), startGUI,
+    Config(..), defaultConfig, startGUI,
     loadFile, loadDirectory,
     
     -- * Browser Window
@@ -68,7 +68,8 @@ import Graphics.UI.Threepenny.Internal.Core
      ToJS, FFI, ffi, JSFunction,
      debug, clear, callFunction, runFunction, callDeferredFunction, atomic, )
 import qualified Graphics.UI.Threepenny.Internal.Types as Core
-import Graphics.UI.Threepenny.Internal.Types (Window, Config, EventData, Session(..))
+import Graphics.UI.Threepenny.Internal.Types
+    (Window, Config, defaultConfig, EventData, Session(..))
 
 {-----------------------------------------------------------------------------
     Server
diff --git a/src/Graphics/UI/Threepenny/Internal/Core.hs b/src/Graphics/UI/Threepenny/Internal/Core.hs
index 70ae7494..4ae0808b 100644
--- a/src/Graphics/UI/Threepenny/Internal/Core.hs
+++ b/src/Graphics/UI/Threepenny/Internal/Core.hs
@@ -97,7 +97,7 @@ import qualified Data.Attoparsec.Enumerator    as Atto
 import           Prelude                       hiding (init)
 import           Safe
 import           Snap.Core
-import           Snap.Http.Server              hiding (Config)
+import qualified Snap.Http.Server              as Snap
 import           Snap.Util.FileServe
 import           System.FilePath
 import qualified Text.JSON as JSON
@@ -119,8 +119,11 @@ serve :: Config -> (Session -> IO ()) -> IO ()
 serve Config{..} worker = do
     server <- newServerState
     _      <- forkIO $ custodian 30 (sSessions server)
-    let config = setPort tpPort defaultConfig
-    httpServe config . route $
+    let config = Snap.setPort tpPort
+               $ Snap.setErrorLog (Snap.ConfigIoLog tpLog)
+               $ Snap.setAccessLog (Snap.ConfigIoLog tpLog)
+               $ Snap.defaultConfig
+    Snap.httpServe config . route $
         routeResources tpCustomHTML tpStatic server
         -- ++ routeCommunication worker server
         ++ routeWebsockets worker server
@@ -383,11 +386,11 @@ readInput = fmap (>>= readMay) . getInput
 ------------------------------------------------------------------------------}
 type Routes = [(ByteString, Snap ())]
 
-routeResources :: Maybe FilePath -> FilePath -> ServerState -> Routes
+routeResources :: Maybe FilePath -> Maybe FilePath -> ServerState -> Routes
 routeResources customHTML staticDir server =
     fixHandlers noCache $
-        [("/static"                    , serveDirectory staticDir)
-        ,("/"                          , root)
+        static ++
+        [("/"                          , root)
         ,("/driver/threepenny-gui.js"  , writeText jsDriverCode )
         ,("/driver/threepenny-gui.css" , writeText cssDriverCode)
         ,("/file/:name"                ,
@@ -397,12 +400,14 @@ routeResources customHTML staticDir server =
         ]
     where
     fixHandlers f routes = [(a,f b) | (a,b) <- routes]
-    noCache h = do
-        modifyResponse $ setHeader "Cache-Control" "no-cache"
-        h
+    noCache h = modifyResponse (setHeader "Cache-Control" "no-cache") >> h
+    
+    static = maybe [] (\dir -> [("/static", serveDirectory dir)]) staticDir
     
     root = case customHTML of
-        Just file -> serveFile (staticDir </> file)
+        Just file -> case staticDir of
+            Just dir -> serveFile (dir </> file)
+            Nothing  -> logError "Graphics.UI.Threepenny: Cannot use tpCustomHTML file without tpStatic"
         Nothing   -> writeText defaultHtmlFile
 
 
diff --git a/src/Graphics/UI/Threepenny/Internal/Types.hs b/src/Graphics/UI/Threepenny/Internal/Types.hs
index 9e643812..08a409f1 100644
--- a/src/Graphics/UI/Threepenny/Internal/Types.hs
+++ b/src/Graphics/UI/Threepenny/Internal/Types.hs
@@ -8,12 +8,14 @@ import Prelude              hiding (init)
 import Control.Applicative
 import Control.Concurrent
 import qualified Reactive.Threepenny as E
-import Data.ByteString               (ByteString)
-import Data.Map             (Map)
+import Data.ByteString               (ByteString, hPut)
+import Data.Map                      (Map)
+import Data.String                   (fromString)
 import Data.Time
 
 import Network.URI
 import Text.JSON.Generic
+import System.IO (stderr)
 
 {-----------------------------------------------------------------------------
     Public types
@@ -85,11 +87,23 @@ data EventData = EventData [Maybe String]
 
 -- | Record for configuring the Threepenny GUI server.
 data Config = Config
-  { tpPort       :: Int               -- ^ Port number.
-  , tpCustomHTML :: Maybe FilePath    -- ^ Custom HTML file to replace the default one.
-  , tpStatic     :: FilePath          -- ^ Directory that is served under @/static@.
+  { tpPort       :: Int                 -- ^ Port number.
+  , tpCustomHTML :: Maybe FilePath      -- ^ Custom HTML file to replace the default one.
+  , tpStatic     :: Maybe FilePath      -- ^ Directory that is served under @/static@.
+  , tpLog        :: ByteString -> IO () -- ^ Print a single log message.
   }
 
+-- | Default configuration.
+--
+-- Port 10000, no custom HTML, no static directory, logging to stderr.
+defaultConfig :: Config
+defaultConfig = Config
+    { tpPort       = 10000
+    , tpCustomHTML = Nothing
+    , tpStatic     = Nothing
+    , tpLog        = \s -> hPut stderr s >> hPut stderr (fromString "\n")
+    }
+
 
 {-----------------------------------------------------------------------------
     Communication between client and server
diff --git a/src/InputElements.hs b/src/InputElements.hs
index e7cd700f..1299e39b 100644
--- a/src/InputElements.hs
+++ b/src/InputElements.hs
@@ -17,10 +17,9 @@ import Paths
 main :: IO ()
 main = do
     static <- getStaticDir
-    startGUI Config
+    startGUI defaultConfig
         { tpPort       = 10000
-        , tpCustomHTML = Nothing
-        , tpStatic     = static
+        , tpStatic     = Just static
         } setup
 
 setup :: Window -> IO ()
diff --git a/src/MissingDollars.hs b/src/MissingDollars.hs
index 5c8ddb76..b37cfb1c 100644
--- a/src/MissingDollars.hs
+++ b/src/MissingDollars.hs
@@ -18,10 +18,9 @@ import Paths
 main :: IO ()
 main = do
     static <- getStaticDir
-    startGUI Config
+    startGUI defaultConfig
         { tpPort       = 10000
-        , tpCustomHTML = Nothing
-        , tpStatic     = static
+        , tpStatic     = Just static
         } setup
 
 
diff --git a/src/Mouse.hs b/src/Mouse.hs
index 104e2131..89847e22 100644
--- a/src/Mouse.hs
+++ b/src/Mouse.hs
@@ -14,12 +14,7 @@ import Graphics.UI.Threepenny.Core
     Main
 ------------------------------------------------------------------------------}
 main :: IO ()
-main = do
-    startGUI Config
-        { tpPort       = 10000
-        , tpCustomHTML = Nothing
-        , tpStatic     = ""
-        } setup
+main = startGUI defaultConfig { tpPort = 10000 } setup
 
 setup :: Window -> IO ()
 setup w = do
diff --git a/src/UseWords.hs b/src/UseWords.hs
index 6d59aa0c..64a22945 100644
--- a/src/UseWords.hs
+++ b/src/UseWords.hs
@@ -25,10 +25,9 @@ import System.FilePath ((</>))
 main :: IO ()
 main = do
     static <- getStaticDir
-    startGUI Config
+    startGUI defaultConfig
         { tpPort       = 10000
-        , tpCustomHTML = Nothing
-        , tpStatic     = static
+        , tpStatic     = Just static
         } setup
 
 
diff --git a/src/VideoAnnotate.hs b/src/VideoAnnotate.hs
index 0b53223f..249cb0a1 100644
--- a/src/VideoAnnotate.hs
+++ b/src/VideoAnnotate.hs
@@ -23,10 +23,9 @@ type Map = Map.Map
 main :: IO ()
 main = do
     static <- getStaticDir
-    startGUI Config
+    startGUI defaultConfig
         { tpPort       = 10000
-        , tpCustomHTML = Nothing
-        , tpStatic     = static
+        , tpStatic     = Just static
         } setup
 
 setup :: Window -> IO ()

From 4de034c1eccfb1c2c8d45b05a026b60c0fef031a Mon Sep 17 00:00:00 2001
From: Heinrich Apfelmus <apfelmus@quantentunnel.de>
Date: Fri, 6 Sep 2013 20:49:52 +0200
Subject: [PATCH 39/41] Administrative. Update examples and documentation.

---
 README.md                     |  2 +-
 src/CurrencyConverter.hs      |  7 ++++++-
 src/Graphics/UI/Threepenny.hs |  5 ++---
 threepenny-gui.cabal          | 10 ++++++++++
 4 files changed, 19 insertions(+), 5 deletions(-)

diff --git a/README.md b/README.md
index 0b5fb25b..3b948b87 100644
--- a/README.md
+++ b/README.md
@@ -27,7 +27,7 @@ This project was originally called Ji in its earliest iterations.
 * [BarTab.hs](https://github.com/HeinrichApfelmus/threepenny-gui/blob/master/src/BarTab.hs) - Dynamic creation of widgets.
 * [Buttons.hs](https://github.com/HeinrichApfelmus/threepenny-gui/blob/master/src/Buttons.hs) - Simple buttons to click on.
 * [Chat.hs](https://github.com/HeinrichApfelmus/threepenny-gui/blob/master/src/Chat.hs) - Multi-user chat.
-* [CurrencyConverter.hs](https://github.com/HeinrichApfelmus/threepenny-gui/blob/master/src/Buttons.hs) - Simple demonstration of two reactive input elements.
+* [CurrencyConverter.hs](https://github.com/HeinrichApfelmus/threepenny-gui/blob/master/src/CurrencyConverter.hs) - Simple demonstration of two reactive input elements.
 * [DragNDropExample.hs](https://github.com/HeinrichApfelmus/threepenny-gui/blob/master/src/DragNDropExample.hs) - Simple drag'N'drop demo.
 * [DrumMachine.hs](https://github.com/HeinrichApfelmus/threepenny-gui/blob/master/src/DrumMachine.hs) - Specify rhythm by activating and deactivating checkboxes.
 * [MissingDollars.hs](https://github.com/HeinrichApfelmus/threepenny-gui/blob/master/src/MissingDollars.hs) - Text with configurable values.
diff --git a/src/CurrencyConverter.hs b/src/CurrencyConverter.hs
index d11e92b9..ec7b9e7a 100644
--- a/src/CurrencyConverter.hs
+++ b/src/CurrencyConverter.hs
@@ -3,15 +3,20 @@
     
     Example: Currency Converter
 ------------------------------------------------------------------------------}
-{-# LANGUAGE RecursiveDo #-}
+{-# LANGUAGE CPP, PackageImports #-}
 
 import Control.Monad (void)
 import Data.Maybe
 import Text.Printf
 import Text.Read     (readMaybe)
 
+#ifdef CABAL
+import qualified "threepenny-gui" Graphics.UI.Threepenny as UI
+import "threepenny-gui" Graphics.UI.Threepenny.Core
+#else
 import qualified Graphics.UI.Threepenny as UI
 import Graphics.UI.Threepenny.Core
+#endif
 
 {-----------------------------------------------------------------------------
     Main
diff --git a/src/Graphics/UI/Threepenny.hs b/src/Graphics/UI/Threepenny.hs
index bd0808d2..2ef30f00 100644
--- a/src/Graphics/UI/Threepenny.hs
+++ b/src/Graphics/UI/Threepenny.hs
@@ -59,10 +59,9 @@ Additional static content is served from the @../wwwroot@ directory.
 
 > main :: IO ()
 > main = do
->     startGUI Config
+>     startGUI defaultConfig
 >         { tpPort       = 10000
->         , tpCustomHTML = Nothing
->         , tpStatic     = "../wwwroot"
+>         , tpStatic     = Just "../wwwroot"
 >         } setup
 
 Whenever a browser connects to the server,
diff --git a/threepenny-gui.cabal b/threepenny-gui.cabal
index 378082c3..409833e6 100644
--- a/threepenny-gui.cabal
+++ b/threepenny-gui.cabal
@@ -130,6 +130,16 @@ Executable threepenny-examples-buttons
     other-modules:     Paths_threepenny_gui, Paths
     hs-source-dirs:    src
 
+Executable threepenny-examples-currencyconverter
+    if flag(buildExamples)
+        cpp-options:       -DCABAL
+        build-depends:     base                      >= 4     && < 5
+                          ,threepenny-gui
+    else
+        buildable: False
+    main-is:           CurrencyConverter.hs
+    hs-source-dirs:    src
+
 Executable threepenny-examples-dragndropexample
     if flag(buildExamples)
         cpp-options:       -DCABAL

From 5f622731ef4de07f492989cb4590c76b9152f93a Mon Sep 17 00:00:00 2001
From: Daniel Mlot <duplode_1@yahoo.com.br>
Date: Sat, 7 Sep 2013 05:47:33 -0300
Subject: [PATCH 40/41] Enable resource file embedding. #27

To work around the Haddock bug, a seemingly superfluous TemplateHaskell pragma
was added to 'Graphics.UI.Threepenny.Internal.Include'.
---
 .../UI/Threepenny/Internal/Include.hs         |  2 +-
 .../UI/Threepenny/Internal/Resources.hs       | 45 ++++++++++---------
 threepenny-gui.cabal                          |  8 ++--
 3 files changed, 29 insertions(+), 26 deletions(-)

diff --git a/src/Graphics/UI/Threepenny/Internal/Include.hs b/src/Graphics/UI/Threepenny/Internal/Include.hs
index d5332f32..ad10c244 100644
--- a/src/Graphics/UI/Threepenny/Internal/Include.hs
+++ b/src/Graphics/UI/Threepenny/Internal/Include.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE TemplateHaskell, CPP #-}
 module Graphics.UI.Threepenny.Internal.Include (include) where
  
 import Data.Functor
diff --git a/src/Graphics/UI/Threepenny/Internal/Resources.hs b/src/Graphics/UI/Threepenny/Internal/Resources.hs
index 5192464b..965ed99a 100644
--- a/src/Graphics/UI/Threepenny/Internal/Resources.hs
+++ b/src/Graphics/UI/Threepenny/Internal/Resources.hs
@@ -3,6 +3,29 @@ module Graphics.UI.Threepenny.Internal.Resources where
 
 import           Data.Text                               (Text)
 import qualified Data.Text                               as Text
+import           Graphics.UI.Threepenny.Internal.Include
+
+
+jsDriverCode    :: Text
+cssDriverCode   :: Text
+defaultHtmlFile :: Text
+
+
+jsDriverCode = Text.unlines $ map Text.pack
+    [ [include|Graphics/UI/jquery.js|]
+    , [include|Graphics/UI/jquery-cookie.js|]
+    , [include|Graphics/UI/driver.js|]
+    ]
+
+cssDriverCode = Text.pack [include|Graphics/UI/driver.css|]
+
+defaultHtmlFile = Text.pack [include|Graphics/UI/index.html|]
+
+
+{-
+-- Disabled code:
+-- Do not embed files with executables.
+
 import qualified Data.Text.IO                            as Text
 import           System.FilePath
 import           System.IO.Unsafe
@@ -16,11 +39,6 @@ getDataDir = return $ "Graphics" </> "UI"
 #endif
 
 
-jsDriverCode    :: Text
-cssDriverCode   :: Text
-defaultHtmlFile :: Text
-
-
 jsDriverCode = unsafePerformIO $
     readFiles $ words "jquery.js jquery-cookie.js driver.js" 
 
@@ -36,19 +54,4 @@ readFiles files = do
 
 getDataFile x = unsafePerformIO $ fmap (</> x) getDataDir
 
-
-{-
--- Temporarily disabled code.
--- Use quasiquotation to bundle resource files with executable.
-
-jsDriverCode = Text.unlines $ map Text.pack
-    [ [include|Graphics/UI/jquery.js|]
-    , [include|Graphics/UI/jquery-cookie.js|]
-    , [include|Graphics/UI/driver.js|]
-    ]
-
-cssDriverCode = Text.pack [include|Graphics/UI/driver.css|]
-
-defaultHtmlFile = Text.pack [include|Graphics/UI/index.html|]
-
--}
\ No newline at end of file
+-}
diff --git a/threepenny-gui.cabal b/threepenny-gui.cabal
index 409833e6..159639de 100644
--- a/threepenny-gui.cabal
+++ b/threepenny-gui.cabal
@@ -39,12 +39,10 @@ Cabal-version:       >=1.8
 
 Extra-Source-Files:  src/Graphics/UI/*.html
                     ,src/Graphics/UI/*.js
+                    ,src/Graphics/UI/*.css
 
 Data-dir:            .
-Data-files:          src/Graphics/UI/*.js
-                    ,src/Graphics/UI/*.html
-                    ,src/Graphics/UI/*.css
-                    ,wwwroot/css/*.css
+Data-files:          wwwroot/css/*.css
                     ,wwwroot/css/*.png
                     ,wwwroot/*.html
                     ,wwwroot/*.txt
@@ -78,6 +76,7 @@ Library
                     ,Control.Concurrent.Delay
                     ,Graphics.UI.Threepenny.Internal.Core
                     ,Graphics.UI.Threepenny.Internal.Resources
+                    ,Graphics.UI.Threepenny.Internal.Include
                     ,Graphics.UI.Threepenny.Internal.Types
                     ,Reactive.Threepenny.PulseLatch
                     ,Reactive.Threepenny.Memo
@@ -101,6 +100,7 @@ Library
                     ,network
                     ,filepath
                     ,data-default
+                    ,template-haskell
                     ,transformers
                     ,stm
                     ,attoparsec-enumerator

From e975ff67127742ea2fdba53b1e6b77ab80e47343 Mon Sep 17 00:00:00 2001
From: Heinrich Apfelmus <apfelmus@quantentunnel.de>
Date: Sat, 7 Sep 2013 18:22:32 +0200
Subject: [PATCH 41/41] Administrative. Update documentation.

---
 README.md                  | 22 +++++++++++++++++++---
 src/Reactive/Threepenny.hs |  6 ++++--
 threepenny-gui.cabal       |  5 ++---
 3 files changed, 25 insertions(+), 8 deletions(-)

diff --git a/README.md b/README.md
index 3b948b87..36500603 100644
--- a/README.md
+++ b/README.md
@@ -1,4 +1,6 @@
-Use the web browser as a GUI, controllable from Haskell.
+Threepenny-gui is a GUI framework that uses the web browser as a display.
+
+* [Project homepage](http://www.haskell.org/haskellwiki/Threepenny-gui)
 
 ## Introduction
 
@@ -12,8 +14,8 @@ What is more, Threepenny is controlled entirely from within Haskell code,
 relieving the user of writing client-side Javascript by hand.
 
 Threepenny comes with a simple web server that is preconfigured to host a 
-client-side JS file called threepenny-gui.js.  The Threepenny API communicates
-with this JS to create new elements, respond to events, and more.  This frequent
+client-side JS file called `threepenny-gui.js`. The Threepenny API communicates
+with this JS to create new elements, respond to events, and more. This frequent
 communication precludes Threepenny from use in high-latency environments.
 
 Users can, however, write their own Javascript if they wish, and invoke that
@@ -87,3 +89,17 @@ can read the pages.
 
 There are plenty more like this, but this is the first that springs to
 mind that is good.
+
+## Contributors
+
+Many thanks to everyone who contributed, provided feedback or simply wrote an application using Threepenny!
+
+* *Heinrich Apfelmus*
+* *Daniel Austin*
+* Daniel Díaz
+* *Daniel Mlot*
+* Luke Palmer
+* Jens Petersen
+* rnons
+
+Special thanks to *Chris Done* for starting the precursor project Ji.
diff --git a/src/Reactive/Threepenny.hs b/src/Reactive/Threepenny.hs
index 343d6ebc..8900fe9c 100644
--- a/src/Reactive/Threepenny.hs
+++ b/src/Reactive/Threepenny.hs
@@ -9,7 +9,7 @@ module Reactive.Threepenny (
     
     -- * IO
     -- | Functions to connect events to the outside world.
-    Handler, newEvent, newEventsNamed, register,
+    Handler, newEvent, register,
     currentValue,
     
     -- * Core Combinators
@@ -36,7 +36,9 @@ module Reactive.Threepenny (
     -- $recursion
     
     -- * Internal
-    onChange, unsafeMapIO,
+    -- | Functions reserved for special circumstances.
+    -- Do not use unless you know what you're doing.
+    onChange, unsafeMapIO, newEventsNamed,
     ) where
 
 import Control.Applicative
diff --git a/threepenny-gui.cabal b/threepenny-gui.cabal
index 159639de..48742b6d 100644
--- a/threepenny-gui.cabal
+++ b/threepenny-gui.cabal
@@ -1,8 +1,8 @@
 Name:                threepenny-gui
 Version:             0.3.0.0
-Synopsis:            Small GUI framework that uses the web browser as a display.
+Synopsis:            GUI framework that uses the web browser as a display.
 Description:
-    Threepenny-GUI is a small GUI framework that uses the web browser as a display.
+    Threepenny-GUI is a GUI framework that uses the web browser as a display.
     .
     It's cheap and easy to install because everyone has a web browser installed.
     .
@@ -12,7 +12,6 @@ Description:
     from your Haskell code.
     .
     Stability forecast: This is an experimental release! Send us your feedback!
-    Basic functionality should work.
     Significant API changes are likely in future versions.
     .
     NOTE: This library contains examples, but they are not built by default.