threepenny-gui 0.2.0.1 → 0.3.0.0

raw patch · 26 files changed

+1614/−729 lines, 26 filesdep +MonadCatchIO-transformersdep +attoparsec-enumeratordep +hashabledep −mtlnew-component:exe:threepenny-examples-currencyconverterPVP ok

version bump matches the API change (PVP)

Dependencies added: MonadCatchIO-transformers, attoparsec-enumerator, hashable, template-haskell, unordered-containers, vault, websockets, websockets-snap

Dependencies removed: mtl

API changes (from Hackage documentation)

Files

• src/BarTab.hs +2/−3
• src/Buttons.hs +2/−3
• src/Chat.hs +29/−21
• src/Control/Event.hs +0/−111
• src/Control/Monad/Extra.hs +0/−30
• src/Control/Monad/IO.hs +0/−8
• src/CurrencyConverter.hs +52/−0
• src/DragNDropExample.hs +2/−3
• src/DrumMachine.hs +11/−14
• src/Graphics/UI/Threepenny.hs +87/−0
• src/Graphics/UI/Threepenny/Canvas.hs +1/−2
• src/Graphics/UI/Threepenny/Core.hs +104/−62
• src/Graphics/UI/Threepenny/Events.hs +26/−3
• src/Graphics/UI/Threepenny/Internal/Core.hs +353/−251
• src/Graphics/UI/Threepenny/Internal/Include.hs +21/−0
• src/Graphics/UI/Threepenny/Internal/Resources.hs +23/−20
• src/Graphics/UI/Threepenny/Internal/Types.hs +38/−28
• src/Graphics/UI/Threepenny/JQuery.hs +1/−1
• src/Graphics/UI/Threepenny/Timer.hs +30/−19
• src/Graphics/UI/driver.js +163/−128
• src/MissingDollars.hs +2/−4
• src/Reactive/Threepenny.hs +357/−0
• src/Reactive/Threepenny/Memo.hs +43/−0
• src/Reactive/Threepenny/PulseLatch.hs +233/−0
• src/UseWords.hs +4/−5
• threepenny-gui.cabal +30/−13

@@ -20,10 +20,9 @@ main :: IO () main = do     static <- getStaticDir-    startGUI Config+    startGUI defaultConfig         { tpPort       = 10000-        , tpCustomHTML = Nothing-        , tpStatic     = static+        , tpStatic     = Just static         } setup  setup :: Window -> IO ()

@@ -19,10 +19,9 @@ main :: IO () main = do     static <- getStaticDir-    startGUI Config+    startGUI defaultConfig         { tpPort       = 10000-        , tpCustomHTML = Nothing-        , tpStatic     = static+        , tpStatic     = Just static         } setup  setup :: Window -> IO ()

@@ -8,6 +8,7 @@ import Data.Functor import Data.List.Extra import Data.Time+import Data.IORef import Prelude hiding (catch)  import Control.Monad.Trans.Reader as Reader@@ -30,24 +31,24 @@ 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)  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,12 +56,16 @@         , element messageArea         ]     -    void $ forkIO $ receiveMessages w msgs messageArea+    messageReceiver <- forkIO $ receiveMessages window msgs messageArea ---    io $ catch (runTP session handleEvents)---             (\e -> do killThread messageReceiver---                       throw (e :: SomeException))+    on UI.disconnect window $ const $ do+        putStrLn "Disconnected!"+        killThread messageReceiver+        now   <- getCurrentTime+        nick  <- readIORef nickRef+        Chan.writeChan msgs (now,nick,"( left the conversation )") + receiveMessages w msgs messageArea = do     messages <- Chan.getChanContents msgs     forM_ messages $ \msg -> do@@ -68,14 +73,14 @@           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 @@     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) =

@@ -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, ())---

@@ -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

@@ -1,8 +0,0 @@-{-# OPTIONS -Wall #-}--module Control.Monad.IO where--import Control.Monad.Trans--io :: MonadIO m => IO a -> m a-io = liftIO

@@ -0,0 +1,52 @@+{-----------------------------------------------------------------------------+    threepenny-gui+    +    Example: Currency Converter+------------------------------------------------------------------------------}+{-# 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+------------------------------------------------------------------------------}+main :: IO ()+main = startGUI defaultConfig { tpPort = 10000 } 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+

@@ -20,10 +20,9 @@ main :: IO () main = do     static <- getStaticDir-    startGUI Config+    startGUI defaultConfig         { tpPort       = 10000-        , tpCustomHTML = Nothing-        , tpStatic     = static+        , tpStatic     = Just static         } setup  setup :: Window -> IO ()

@@ -38,10 +38,9 @@ main :: IO () main = do     static <- getStaticDir-    startGUI Config+    startGUI defaultConfig         { tpPort       = 10000-        , tpCustomHTML = Nothing-        , tpStatic     = static+        , tpStatic     = Just static         } setup  setup :: Window -> IO ()@@ -55,21 +54,17 @@                       ,[UI.string "Beat:", element elTick]]     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)+    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)-                 -- play corresponding sounds         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)     @@ -97,7 +92,9 @@     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]     

@@ -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,83 @@ 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 defaultConfig+>         { tpPort       = 10000+>         , tpStatic     = Just "../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>.+++-}+

@@ -4,10 +4,9 @@          -- * Documentation     Canvas,-    drawImage, clearCanvas,+    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

@@ -1,10 +1,11 @@+{-# LANGUAGE DeriveDataTypeable, RecordWildCards #-} module Graphics.UI.Threepenny.Core (-    -- * Guide-    -- $guide+    -- * Synopsis+    -- | Core functionality of the Threepenny GUI library.          -- * Server     -- $server-    Config(..), startGUI,+    Config(..), defaultConfig, startGUI,     loadFile, loadDirectory,          -- * Browser Window@@ -16,7 +17,9 @@         getHead, getBody,         children, text, html, attr, style, value,     getValuesList,-    getElementsByTagName, getElementByTagName, getElementsById, getElementById,+    getElementsByTagName, getElementByTagName, +    getElementsById, getElementById,+    getElementsByClassName,          -- * Layout     -- | Combinators for quickly creating layouts.@@ -25,14 +28,14 @@          -- * Events     -- | For a list of predefined events, see "Graphics.UI.Threepenny.Events".-    EventData(..), domEvent, on,-    module Control.Event,+    EventData(..), domEvent, on, disconnect,+    module Reactive.Threepenny,          -- * Attributes     -- | 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.@@ -41,21 +44,23 @@     callDeferredFunction, atomic,          -- * Internal and oddball functions-    updateElement, manifestElement, audioPlay, fromProp,+    updateElement, manifestElement, fromProp,+    audioPlay, audioStop,          ) where +import Data.Dynamic import Data.IORef+import qualified Data.Map as Map 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 Control.Monad.Trans.Reader as Reader import Network.URI import Text.JSON+import Reactive.Threepenny  import qualified Graphics.UI.Threepenny.Internal.Core  as Core import Graphics.UI.Threepenny.Internal.Core@@ -63,38 +68,8 @@      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)--{------------------------------------------------------------------------------    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.---}-+import Graphics.UI.Threepenny.Internal.Types+    (Window, Config, defaultConfig, EventData, Session(..))  {-----------------------------------------------------------------------------     Server@@ -106,6 +81,13 @@ (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.@@ -113,8 +95,7 @@     :: 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.@@ -146,7 +127,10 @@ type Value = String  -- | Reference to an element in the DOM of the client window.-newtype Element = Element (MVar Elem)+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@@ -155,11 +139,13 @@ -- 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@@ -172,14 +158,23 @@ -- 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     :: Element   -- ^ Parent.@@ -194,9 +189,18 @@ 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,@@ -205,7 +209,7 @@ -- 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@@ -248,8 +252,8 @@ 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@@ -316,17 +320,31 @@ 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 ------------------------------------------------------------------------------}-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 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"@@ -387,7 +405,9 @@         --   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 events _) = events name++{-        ref <- newIORef $ return ()     let         -- register handler and remember unregister function@@ -401,7 +421,16 @@          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.@@ -464,6 +493,19 @@ -- Best used in conjunction with '#'. 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

@@ -1,16 +1,39 @@ module Graphics.UI.Threepenny.Events (     -- * Synopsis-    -- | Common DOM events, for convenience.+    -- | Events on DOM elements.     -    -- * Documentation+    -- * Convenience events+    valueChange, selectionChange, checkedChange,+    +    -- * Standard DOM events     click, mousemove, hover, blur, leave,-    keyup, keydown,+    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)++-- | 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+------------------------------------------------------------------------------} -- | Mouse click. click :: Element -> Event () click = silence . domEvent "click"

@@ -1,15 +1,12 @@ {-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings, PackageImports #-} {-# 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@@ -18,9 +15,8 @@   -- * Event handling   -- $eventhandling   ,bind-  ,handleEvent-  ,handleEvents-  ,module Control.Event+  ,disconnect+  ,module Reactive.Threepenny      -- * Setting attributes   -- $settingattributes@@ -44,6 +40,7 @@   ,getBody   ,getElementsByTagName   ,getElementsById+  ,getElementsByClassName   ,getWindow   ,getProp   ,getValue@@ -63,9 +60,6 @@   ,ToJS, FFI, ffi, JSFunction   ,runFunction, callFunction   -  -- * Oddball-  ,audioPlay-     -- * Types   ,Window   ,Element@@ -73,10 +67,8 @@   ,EventData(..)   ) where ------------------------------------------------------------------------------------- Imports + import           Graphics.UI.Threepenny.Internal.Types     as Threepenny import           Graphics.UI.Threepenny.Internal.Resources @@ -84,10 +76,11 @@ import           Control.Concurrent 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 qualified Control.Exception+import           Reactive.Threepenny+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)@@ -98,17 +91,21 @@ 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 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 import           Text.JSON.Generic   {------------------------------------------------------------------------------    Server running+    Server and and session management ------------------------------------------------------------------------------} newServerState :: IO ServerState newServerState = ServerState @@ -118,12 +115,18 @@  -- | 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 = 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  -- | Kill sessions after at least n seconds of disconnectedness. custodian :: Integer -> MVar Sessions -> IO ()@@ -137,44 +140,282 @@         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) --- 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))-              ]+-- 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 <- liftIO $ withMVar sSessions return+    case M.lookup token sessions of+        Nothing      -> error $ "Nonexistant token: " ++ show token+        Just session -> cont session++{-----------------------------------------------------------------------------+    Implementation of two-way communication+    - POST and GET requests+------------------------------------------------------------------------------}+-- | 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 sServerState sStartInfo sToken = do+    sSignals          <- newChan+    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..]+    let session = Session {..}+    initializeElementEvents session    +    return session++-- | Make a new session and add it to the server+createSession :: (Session -> IO void) -> ServerState -> Snap Session+createSession worker server = do+    -- 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))+        session <- newSession server (uri,params) newKey+        _       <- forkIO $ void $ worker session >> handleEvents 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)++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+    let setDisconnected = do+        now <- getCurrentTime+        modifyMVar_ sConnectedState (const (return (Disconnected now)))+    +    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+            -- no instructions available after some time+            when (e == Control.Exception.ThreadKilled) $ 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 = JSON.decode signalJson+        case signal of+          Ok signal -> liftIO $ writeChan sSignals signal+          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)+        error "Threepenny.Internal.Core: runWebSocketsSnap should never return."+++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+    sendData <- liftIO . forkIO . forever $ do+        x <- readChan sInstructions+        WS.sendSink send . WS.textData . Text.pack . JSON.encode $ x++    -- read data+    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+------------------------------------------------------------------------------}+-- | 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++-- | 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+------------------------------------------------------------------------------}+-- 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 -> Maybe FilePath -> ServerState -> Routes+routeResources customHTML staticDir server =+    fixHandlers noCache $+        static +++        [("/"                          , 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 = modifyResponse (setHeader "Cache-Control" "no-cache") >> h+    +    static = maybe [] (\dir -> [("/static", serveDirectory dir)]) staticDir+         root = case customHTML of-        Just file -> serveFile (wwwroot </> 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 + -- Get a filename from a URI 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@@ -202,117 +443,7 @@     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 ------------------------------------------------------------------------------}@@ -329,42 +460,71 @@  -- | 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 ()+            handleEvent1 window ((elid,eventType),EventData params)+            handleEvents window+        Quit () -> do+            snd sEventQuit ()+            -- 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 --- | 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) =-    Control.Event.Event register-    where-    key        = (elid, eventType)-    register h = do-        -- register with server-        unregister <- Control.Event.register (sEvent session key) h-        -- register with client+    -> 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)-        return unregister+    -- register with server+    addEventHandler session (key, handler) +-- | Register event handler that occurs when the client has disconnected.+disconnect :: Window -> Event ()+disconnect = fst . sEventQuit+++initializeElementEvents :: Window -> IO ()+initializeElementEvents session@(Session{..}) = do+        initEvents =<< getHead session+        initEvents =<< getBody session+    where+    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-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)  {-----------------------------------------------------------------------------@@ -437,7 +597,6 @@            -> 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)@@ -452,15 +611,7 @@     --       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 ------------------------------------------------------------------------------} -- $querying@@ -490,6 +641,17 @@       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.@@ -538,36 +700,6 @@     -> 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@@ -597,34 +729,4 @@  -- | 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)+clear window = runFunction window $ ffi "$('body').contents().detach()"

@@ -0,0 +1,21 @@+{-# LANGUAGE TemplateHaskell, CPP #-}+module Graphics.UI.Threepenny.Internal.Include (include) where+ +import Data.Functor+import qualified Language.Haskell.TH as TH+import Language.Haskell.TH.Quote++#ifdef CABAL+root = "src/"+#else+root = ""+#endif++include = QuasiQuoter+        { quoteExp  = f             -- only used as an expression,+        , quotePat  = undefined     -- hence all other use cases undefined+        , quoteType = undefined+        , quoteDec  = undefined+        }+    where+    f s = TH.LitE . TH.StringL <$> TH.runIO (readFile $ root ++ s)

@@ -3,6 +3,29 @@  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 @@ #endif  -jsDriverCode    :: Text-cssDriverCode   :: Text-defaultHtmlFile :: Text-- jsDriverCode = unsafePerformIO $     readFiles $ words "jquery.js jquery-cookie.js driver.js"  @@ -35,20 +53,5 @@     return $ Text.unlines ys  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|]  -}

@@ -7,14 +7,15 @@  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 qualified Reactive.Threepenny as E+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@@ -31,7 +32,7 @@  -- | 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@@ -39,34 +40,37 @@     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-  , sEvent          :: EventKey -> E.Event EventData-  , sEventHandler   :: E.Handler (EventKey, EventData)+  , 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-  , sMutex          :: MVar ()   , sConnectedState :: MVar ConnectedState   , sThreadId       :: ThreadId   , sStartInfo      :: (URI,[(String,String)])   , sServerState    :: ServerState   } -type Sessions  = Map Integer Session-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     , sFiles    :: MVar Filepaths     , sDirs     :: MVar Filepaths     } -type EventKey = (String, String)  -- | The client browser window. type Window = Session@@ -83,12 +87,24 @@  -- | 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 ------------------------------------------------------------------------------}@@ -96,10 +112,8 @@ -- | An instruction that is sent to the client as JSON. data Instruction   = Debug String-  | Begin ()-  | End ()   | SetToken Integer-  | Clear ()+  | GetElementsByClassName String   | GetElementsById [String]   | GetElementsByTagName String   | SetStyle ElementId [(String,String)]@@ -111,7 +125,6 @@   | GetValue ElementId   | GetValues [ElementId]   | SetTitle String-  | GetLocation ()   | RunJSFunction String   | CallJSFunction String   | CallDeferredFunction (Closure,String,[String])@@ -125,34 +138,31 @@  -- | A signal (mostly events) that are sent from the client to the server. data Signal-  = Init ()+  = Quit ()   | Elements [ElementId]   | Event (String,String,[Maybe String])   | Value String   | Values [String]-  | Location 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+    let quit     = Quit <$> valFromObj "Quit" obj         elements = Elements <$> valFromObj "Elements" obj         event = do           (cid,typ,arguments) <- valFromObj "Event" obj           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-         <|> fcallvalues <|> fresult+    quit <|> elements <|> event <|> value <|> values <|> fcallvalues <|> fresult  -- | Read a JSValue that may be null. nullable :: JSON a => JSValue -> Result (Maybe a)@@ -161,7 +171,7 @@  -- | 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)  {-----------------------------------------------------------------------------

@@ -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 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)

@@ -1,55 +1,63 @@-{-# 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 import Control.Concurrent.STM+import Reactive.Threepenny  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 @@ 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)   {-----------------------------------------------------------------------------

@@ -46,20 +46,34 @@   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); }+  }++  ////////////////////////////////////////////////////////////////////////////////   // Main entry point   $(document).ready(function(){-    setTimeout(function(){-      waitForEvents();-    })+    // initCommunicationHTTP();+    initCommunicationWebSockets();   });    ////////////////////////////////////////////////////////////////////////////////-  // Running instructions--  window.do_logging = function(x){-    $.cookie('tp_log',x.toString());-  };-    +  // Client-server communication+  // - GET and POST requests+  +  // Initialize communication via HTTP requests.+  function initCommunicationHTTP() {+    setTimeout(function(){+      waitForEvents();+    })+  }+  +  // Poll instruction from the server.   function waitForEvents(){     console_log("Polling… (%d signals so far)",signal_count);     var data = { token: sessionToken };@@ -79,8 +93,8 @@           console_log('Event list:');           runMultipleEvents(events);         } else {-          runEvent(events,function(){-            waitForEvents();+          runEvent(events, signalEvent, function(response){+            maybeReply(response, waitForEvents);           });         }       },@@ -97,12 +111,94 @@     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++;+    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);+      }+    });+  }+  +  ////////////////////////////////////////////////////////////////////////////////+  // 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);+    +    $(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}));+    }+    var reply     = function (response) {+      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);+        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);+      }+    }+  } -  function runEvent(event,continuation){++  ////////////////////////////////////////////////////////////////////////////////+  // FFI - Execute and reply to commands from the server+  +  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){@@ -114,7 +210,7 @@         // 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": {@@ -125,39 +221,30 @@         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();-        break;-      }-      case "Clear": {-        $('body').contents().detach();-        continuation();+        reply();         break;       }       case "GetElementsByTagName": {@@ -169,11 +256,7 @@             Element: elementToElid(elements[i])           });         }-        signal({-          Elements: els-        },function(){-          continuation();-        });+        reply({ Elements: els });         break;       }       case "GetElementsById": {@@ -188,13 +271,21 @@                 });             }         }-        signal({-          Elements: els-        },function(){-          continuation();-        });+        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];@@ -204,7 +295,7 @@         for(var i = 0; i < len; i++){           el.style[style[i][0]] = style[i][1];         }-        continuation();+        reply();         break;       }       case "SetAttr": {@@ -214,26 +305,14 @@         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();-        });-        break;-      }-      case "GetLocation": {-        signal({-          Location: window.location.href-        },function(){-          continuation();-        });+        reply({ Value: value });         break;       }       case "GetValues": {@@ -243,34 +322,30 @@         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": {@@ -281,93 +356,48 @@         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();       }     }   } -  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,17 +450,17 @@     }   } -  // 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));     $(el).animate(JSON.parse(props),@@ -442,6 +472,11 @@   window.jquery_scrollToBottom = function(el){     $(el).scrollTop(el.scrollHeight);   };++  function prim_audio_stop(audio){+    audio.pause();+    audio.currentTime = 0;+  }    // see http://stackoverflow.com/a/9722502/403805   CanvasRenderingContext2D.prototype.clear = 

@@ -1,7 +1,6 @@ {-# LANGUAGE CPP, PackageImports #-}  import Control.Monad-import Control.Monad.Extra import Safe  #ifdef CABAL@@ -19,10 +18,9 @@ main :: IO () main = do     static <- getStaticDir-    startGUI Config+    startGUI defaultConfig         { tpPort       = 10000-        , tpCustomHTML = Nothing-        , tpStatic     = static+        , tpStatic     = Just static         } setup  

@@ -0,0 +1,357 @@+{-# LANGUAGE RecursiveDo  #-}+module Reactive.Threepenny (+    -- * Synopsis+    -- | Functional reactive programming.+    +    -- * Types+    -- $intro+    Event, Behavior,+    +    -- * IO+    -- | Functions to connect events to the outside world.+    Handler, newEvent, register,+    currentValue,+    +    -- * 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,+    -- ** Union+    unions, concatenate,+    -- ** Accumulation+    -- $accumulation+    accumB, mapAccum,++    -- * Additional Notes+    -- $recursion+    +    -- * Internal+    -- | Functions reserved for special circumstances.+    -- Do not use unless you know what you're doing.+    onChange, unsafeMapIO, newEventsNamed,+    ) where++import Control.Applicative+import Control.Monad (void)+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+------------------------------------------------------------------------------}+{- $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 () }++{-----------------------------------------------------------------------------+    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, Handler a)+newEvent = do+    (p, fire) <- Prim.newPulse+    return (E $ fromPure p, fire)+++-- | Create a series of events with delayed initialization.+--+-- 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.+-- +-- When registering an event handler, you will also be given an action+-- that unregisters this handler again.+-- +-- > do unregisterMyHandler <- register event myHandler+--+-- 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+    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 l e) h = void $ do+    -- This works because latches are updated before the handlers are being called.+    register e (\_ -> h =<< Prim.readLatch l)++-- | Read the current value of a 'Behavior'.+currentValue :: Behavior a -> IO a+currentValue (B l _) = Prim.readLatch l+++{-----------------------------------------------------------------------------+    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)++-- | Event that never occurs.+-- Think of it as @never = []@.+never :: Event a+never = E $ fromPure Prim.neverP++-- | 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)++-- | 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+--+-- > 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 '<*>'.+(<@>) :: Behavior (a -> b) -> Event a -> Event b+(<@>) = apply++-- | 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)+    return $ E $ fromPure p++instance Functor Behavior where+    fmap f ~(B l e) = B (Prim.mapL f l) e++instance Applicative Behavior where+    pure a  = B (Prim.pureL a) never+    ~(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++-- | 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!+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+------------------------------------------------------------------------------}+test :: IO (Int -> IO ())+test = do+    (e1,fire) <- newEvent+    e2 <- accumE 0 $ (+) <$> e1+    _  <- register e2 print+    +    return fire+    +test_recursion1 :: IO (IO ())+test_recursion1 = mdo+    (e1, fire) <- newEvent+    let e2 :: Event Int+        e2 = apply (const <$> b) e1+    b  <- accumB 0 $ (+1) <$ e2+    _  <- register e2 print+    +    return $ fire ()++

@@ -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    -- allow some recursion+            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

@@ -0,0 +1,233 @@+{-# LANGUAGE RecordWildCards, RecursiveDo #-}+module Reactive.Threepenny.PulseLatch (+    Pulse, newPulse, addHandler,+    neverP, mapP, filterJustP, unionWithP, unsafeMapIOP,+    +    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 hashWithSalt _ = 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)++-- | 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)++-- | 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+    let 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 -> 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 -> Latch b+applyL l1 l2 = Latch { readL = readL l1 <*> readL l2 }++{-----------------------------------------------------------------------------+    Test+------------------------------------------------------------------------------}+test :: IO (Int -> IO ())+test = do+    (p1, fire) <- newPulse+    p2     <- mapP (+) p1+    (l1,_) <- accumL 0 p2+    let 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+    let l2  =  mapL const l1+    addHandler p2 print+    return $ fire ()

@@ -11,10 +11,10 @@  #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 ((</>))@@ -25,10 +25,9 @@ main :: IO () main = do     static <- getStaticDir-    startGUI Config+    startGUI defaultConfig         { tpPort       = 10000-        , tpCustomHTML = Nothing-        , tpStatic     = static+        , tpStatic     = Just static         } setup  

@@ -1,8 +1,8 @@ Name:                threepenny-gui-Version:             0.2.0.1-Synopsis:            Small GUI framework that uses the web browser as a display.+Version:             0.3.0.0+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 @@     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.@@ -22,6 +21,8 @@     .     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.@@ -37,12 +38,10 @@  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@@ -51,7 +50,7 @@  flag buildExamples     description: Build example executables.-    default:     True+    default:     False  Source-repository head     type:               git@@ -61,7 +60,7 @@ Library   Hs-source-dirs:    src   Exposed-modules:-                     Control.Event+                     Reactive.Threepenny                     ,Graphics.UI.Threepenny                     ,Graphics.UI.Threepenny.Attributes                     ,Graphics.UI.Threepenny.Core@@ -73,21 +72,26 @@                     ,Graphics.UI.Threepenny.Timer   Other-modules:                      Control.Concurrent.Chan.Extra-                    ,Control.Monad.Extra-                    ,Control.Monad.IO                     ,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                     ,Paths_threepenny_gui   CPP-Options:      -DCABAL   Build-depends:     base                      >= 4     && < 5                     ,snap-server                     ,snap-core-                    ,mtl+                    ,websockets+                    ,websockets-snap                     ,text                     ,safe                     ,containers+                    ,unordered-containers+                    ,hashable+                    ,vault == 0.3.*                     ,bytestring                     ,json >= 0.4.4 && < 0.6                     ,time@@ -95,8 +99,11 @@                     ,network                     ,filepath                     ,data-default+                    ,template-haskell                     ,transformers                     ,stm+                    ,attoparsec-enumerator+                    ,MonadCatchIO-transformers                      Executable threepenny-examples-bartab     if flag(buildExamples)@@ -120,6 +127,16 @@         buildable: False     main-is:           Buttons.hs     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