diff --git a/src/BarTab.hs b/src/BarTab.hs --- a/src/BarTab.hs +++ b/src/BarTab.hs @@ -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 () diff --git a/src/Buttons.hs b/src/Buttons.hs --- a/src/Buttons.hs +++ b/src/Buttons.hs @@ -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 () diff --git a/src/Chat.hs b/src/Chat.hs --- a/src/Chat.hs +++ b/src/Chat.hs @@ -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) = diff --git a/src/Control/Event.hs b/src/Control/Event.hs deleted file mode 100644 --- a/src/Control/Event.hs +++ /dev/null @@ -1,111 +0,0 @@ -module Control.Event ( - -- * Synopsis - -- | Event-driven programming in the imperative style. - - -- * Documentation - Handler, Event(..), - mapIO, filterIO, filterJust, - newEvent, newEventsTagged - ) where - - -import Data.IORef -import qualified Data.Unique -- ordinary uniques here, because they are Ord - -import qualified Data.Map as Map - -type Map = Map.Map - -{----------------------------------------------------------------------------- - Types -------------------------------------------------------------------------------} --- | An /event handler/ is a function that takes an --- /event value/ and performs some computation. -type Handler a = a -> IO () - - --- | An /event/ is a facility for registering --- event handlers. These will be called whenever the event occurs. --- --- When registering an event handler, you will also be given an action --- that unregisters this handler again. --- --- > do unregisterMyHandler <- register event myHandler --- -newtype Event a = Event { register :: Handler a -> IO (IO ()) } - -{----------------------------------------------------------------------------- - Combinators -------------------------------------------------------------------------------} -instance Functor Event where - fmap f = mapIO (return . f) - --- | Map the event value with an 'IO' action. -mapIO :: (a -> IO b) -> Event a -> Event b -mapIO f e = Event $ \h -> register e $ \x -> f x >>= h - --- | Filter event values that don't return 'True'. -filterIO :: (a -> IO Bool) -> Event a -> Event a -filterIO f e = Event $ \h -> - register e $ \x -> f x >>= \b -> if b then h x else return () - --- | Keep only those event values that are of the form 'Just'. -filterJust :: Event (Maybe a) -> Event a -filterJust e = Event $ \g -> register e (maybe (return ()) g) - - -{----------------------------------------------------------------------------- - Construction -------------------------------------------------------------------------------} --- | Build a facility to register and unregister event handlers. --- Also yields a function that takes an event handler and runs all the registered --- handlers. --- --- Example: --- --- > do --- > (event, fire) <- newEvent --- > register event (putStrLn) --- > fire "Hello!" -newEvent :: IO (Event a, a -> IO ()) -newEvent = do - handlers <- newIORef Map.empty - let register handler = do - key <- Data.Unique.newUnique - atomicModifyIORef_ handlers $ Map.insert key handler - return $ atomicModifyIORef_ handlers $ Map.delete key - runHandlers a = - mapM_ ($ a) . map snd . Map.toList =<< readIORef handlers - return (Event register, runHandlers) - --- | Build several 'Event's from case analysis on a tag. --- Generalization of 'newEvent'. -newEventsTagged :: Ord tag => IO (tag -> Event a, (tag, a) -> IO ()) -newEventsTagged = do - handlersRef <- newIORef Map.empty -- :: Map key (Map Unique (Handler a)) - - let register tag handler = do - -- new identifier for this handler - uid <- Data.Unique.newUnique - -- add handler to map at key - atomicModifyIORef_ handlersRef $ - Map.alter (Just . Map.insert uid handler . maybe Map.empty id) tag - -- remove handler from map at key - return $ atomicModifyIORef_ handlersRef $ - Map.adjust (Map.delete uid) tag - - let runHandlers (tag,a) = do - handlers <- readIORef handlersRef - case Map.lookup tag handlers of - Just hs -> mapM_ ($ a) (Map.elems hs) - Nothing -> return () - - return (\tag -> Event (register tag), runHandlers) - -{----------------------------------------------------------------------------- - Utilities -------------------------------------------------------------------------------} -atomicModifyIORef_ ref f = atomicModifyIORef ref $ \x -> (f x, ()) - - - diff --git a/src/Control/Monad/Extra.hs b/src/Control/Monad/Extra.hs deleted file mode 100644 --- a/src/Control/Monad/Extra.hs +++ /dev/null @@ -1,30 +0,0 @@ --- | Extra utilities for monads. - -module Control.Monad.Extra where - -import Data.Maybe - --- | Ignore the given action's return. -ig :: (Monad m) => m a -> m () -ig m = m >> return () - --- | A non-operator version of (=<<). -bind :: (Monad m) => (a -> m b) -> m a -> m b -bind = flip (>>=) - --- | When the value is Just, run the action. -whenJust :: Monad m => Maybe a -> (a -> m ()) -> m () -whenJust (Just a) m = m a -whenJust Nothing _ = return () - --- | Wrap up a functor in a Maybe. -just :: Functor m => m a -> m (Maybe a) -just = fmap Just - --- | Flip mapMaybe. -forMaybe :: [a] -> (a -> Maybe b) -> [b] -forMaybe = flip mapMaybe - --- | Monadic version of maybe. -maybeM :: (Monad m) => a -> (a1 -> m a) -> Maybe a1 -> m a -maybeM nil cons a = maybe (return nil) cons a diff --git a/src/Control/Monad/IO.hs b/src/Control/Monad/IO.hs deleted file mode 100644 --- a/src/Control/Monad/IO.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# OPTIONS -Wall #-} - -module Control.Monad.IO where - -import Control.Monad.Trans - -io :: MonadIO m => IO a -> m a -io = liftIO diff --git a/src/CurrencyConverter.hs b/src/CurrencyConverter.hs new file mode 100644 --- /dev/null +++ b/src/CurrencyConverter.hs @@ -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 + diff --git a/src/DragNDropExample.hs b/src/DragNDropExample.hs --- a/src/DragNDropExample.hs +++ b/src/DragNDropExample.hs @@ -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 () diff --git a/src/DrumMachine.hs b/src/DrumMachine.hs --- a/src/DrumMachine.hs +++ b/src/DrumMachine.hs @@ -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] diff --git a/src/Graphics/UI/Threepenny.hs b/src/Graphics/UI/Threepenny.hs --- a/src/Graphics/UI/Threepenny.hs +++ b/src/Graphics/UI/Threepenny.hs @@ -1,4 +1,11 @@ module Graphics.UI.Threepenny ( + -- * Introduction + -- $intro + + -- * Example + -- $example + + -- * Modules module Graphics.UI.Threepenny.Attributes, module Graphics.UI.Threepenny.Core, module Graphics.UI.Threepenny.Canvas, @@ -17,3 +24,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 +. + + +-} + diff --git a/src/Graphics/UI/Threepenny/Canvas.hs b/src/Graphics/UI/Threepenny/Canvas.hs --- a/src/Graphics/UI/Threepenny/Canvas.hs +++ b/src/Graphics/UI/Threepenny/Canvas.hs @@ -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 diff --git a/src/Graphics/UI/Threepenny/Core.hs b/src/Graphics/UI/Threepenny/Core.hs --- a/src/Graphics/UI/Threepenny/Core.hs +++ b/src/Graphics/UI/Threepenny/Core.hs @@ -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 diff --git a/src/Graphics/UI/Threepenny/Events.hs b/src/Graphics/UI/Threepenny/Events.hs --- a/src/Graphics/UI/Threepenny/Events.hs +++ b/src/Graphics/UI/Threepenny/Events.hs @@ -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 @