threepenny-gui 0.3.0.1 → 0.4.0.0
raw patch · 44 files changed
+2696/−2180 lines, 44 filesdep +deepseqdep ~MonadCatchIO-transformersdep ~attoparsec-enumeratordep ~bytestringnew-component:exe:threepenny-examples-crud
Dependencies added: deepseq
Dependency ranges changed: MonadCatchIO-transformers, attoparsec-enumerator, bytestring, containers, data-default, filepath, hashable, network, safe, snap-core, snap-server, stm, template-haskell, text, time, transformers, unordered-containers, utf8-string, websockets, websockets-snap
Files
- CHANGELOG.md +25/−0
- LICENSE +13/−0
- samples/BarTab.hs +77/−0
- samples/Buttons.hs +78/−0
- samples/CRUD.hs +138/−0
- samples/Chat.hs +106/−0
- samples/CurrencyConverter.hs +40/−0
- samples/Data/List/Extra.hs +8/−0
- samples/DragNDropExample.hs +66/−0
- samples/DrumMachine.hs +93/−0
- samples/MissingDollars.hs +134/−0
- samples/Paths.hs +20/−0
- samples/Tidings.hs +37/−0
- samples/UseWords.hs +101/−0
- src/BarTab.hs +0/−86
- src/Buttons.hs +0/−84
- src/Chat.hs +0/−116
- src/CurrencyConverter.hs +0/−52
- src/Data/List/Extra.hs +0/−8
- src/DragNDropExample.hs +0/−72
- src/DrumMachine.hs +0/−105
- src/Foreign/Coupon.hs +181/−0
- src/Graphics/UI/Threepenny.hs +4/−2
- src/Graphics/UI/Threepenny/Canvas.hs +5/−11
- src/Graphics/UI/Threepenny/Core.hs +245/−217
- src/Graphics/UI/Threepenny/Elements.hs +2/−2
- src/Graphics/UI/Threepenny/Events.hs +27/−8
- src/Graphics/UI/Threepenny/Internal/Core.hs +0/−732
- src/Graphics/UI/Threepenny/Internal/Driver.hs +673/−0
- src/Graphics/UI/Threepenny/Internal/FFI.hs +130/−0
- src/Graphics/UI/Threepenny/Internal/Include.hs +8/−2
- src/Graphics/UI/Threepenny/Internal/Types.hs +102/−148
- src/Graphics/UI/Threepenny/JQuery.hs +7/−9
- src/Graphics/UI/Threepenny/Timer.hs +8/−5
- src/Graphics/UI/Threepenny/Widgets.hs +120/−0
- src/Graphics/UI/driver.js +59/−148
- src/MissingDollars.hs +0/−140
- src/Paths.hs +0/−20
- src/Reactive/Threepenny.hs +44/−9
- src/Reactive/Threepenny/Monads.hs +12/−0
- src/Reactive/Threepenny/PulseLatch.hs +8/−32
- src/Reactive/Threepenny/Types.hs +39/−0
- src/UseWords.hs +0/−109
- threepenny-gui.cabal +86/−63
+ CHANGELOG.md view
@@ -0,0 +1,25 @@+## Changelog for the `threepenny-gui` package++**0.4.0.0** -- Snapshot release.++* New `UI` monad for easier JavaScript FFI and recursion in FRP.+* Garbage collection for DOM elements. (Unfortunately, this doesn't support using custom HTML files anymore, see [issue #60][60].)+* First stab at widgets.+* Update dependency to `websockets-0.8`.++**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.++++ [60]: https://github.com/HeinrichApfelmus/threepenny-gui/issues/60
LICENSE view
@@ -1,3 +1,16 @@+The following license ("BSD3") applies to almost all files in this project,+in particular the source code indicated in the `threepenny-gui.cabal` file.+Exceptions are audio sample (*.wav) files,+and files whose content explicitely indicates a different license.++--++Copyright (c) 2013, Heinrich Apfelmus <https://github.com/HeinrichApfelmus/>+Copyright (c) 2013, Daniel Austin <https://github.com/daniel-r-austin>+Copyright (c) 2013, Daniel Mlot <https://github.com/duplode>+Copyright (c) 2013, Rnons <https://github.com/rnons>+Copyright (c) 2012, Jeremy Bowers <https://github.com/thejerf>+Copyright (c) 2011-2012, Chris Done <https://github.com/chrisdone> All rights reserved. Redistribution and use in source and binary forms, with or without
+ samples/BarTab.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}++import Control.Applicative+import Control.Monad+import Data.IORef+import Data.Maybe++import qualified Graphics.UI.Threepenny as UI+import Graphics.UI.Threepenny.Core+++-- | Main entry point.+main :: IO ()+main = startGUI defaultConfig { tpPort = 10000 } setup++setup :: Window -> UI ()+setup w = do+ -- active elements+ return w # set title "BarTab"++ elAdd <- UI.button # set UI.text "Add"+ elRemove <- UI.button # set UI.text "Remove"+ elResult <- UI.span++ inputs <- liftIO $ newIORef []+ + -- functionality+ let+ displayTotal = void $ do+ xs <- getValuesList =<< liftIO (readIORef inputs)+ element elResult # set text (showNumber . sum $ map readNumber xs)+ + redoLayout :: UI ()+ redoLayout = void $ do+ layout <- mkLayout =<< liftIO (readIORef inputs)+ getBody w # set children [layout]+ displayTotal++ mkLayout :: [Element] -> UI Element+ mkLayout xs = column $+ [row [element elAdd, element elRemove]+ ,UI.hr]+ ++ map element xs +++ [UI.hr+ ,row [UI.span # set text "Sum: ", element elResult]+ ]+ + addInput :: UI ()+ addInput = do+ elInput <- UI.input # set value "0"+ on (domEvent "livechange") elInput $ \_ -> displayTotal+ liftIO $ modifyIORef inputs (elInput:)+ + removeInput :: UI ()+ removeInput = liftIO $ modifyIORef inputs (drop 1)+ + on UI.click elAdd $ \_ -> addInput >> redoLayout+ on UI.click elRemove $ \_ -> removeInput >> redoLayout+ addInput >> redoLayout+++{-----------------------------------------------------------------------------+ Functionality+------------------------------------------------------------------------------}+type Number = Maybe Double++instance Num Number where+ (+) = liftA2 (+)+ (-) = liftA2 (-)+ (*) = liftA2 (*)+ abs = fmap abs+ signum = fmap signum+ fromInteger = pure . fromInteger++readNumber :: String -> Number+readNumber s = listToMaybe [x | (x,"") <- reads s] +showNumber = maybe "--" show
+ samples/Buttons.hs view
@@ -0,0 +1,78 @@+import Control.Monad+import Control.Concurrent (threadDelay)++import Paths++import qualified Graphics.UI.Threepenny as UI+import Graphics.UI.Threepenny.Core++{-----------------------------------------------------------------------------+ Buttons+------------------------------------------------------------------------------}++main :: IO ()+main = do+ static <- getStaticDir+ startGUI defaultConfig+ { tpPort = 10000+ , tpStatic = Just static+ } setup++setup :: Window -> UI ()+setup w = void $ do+ return w # set title "Buttons"+ UI.addStyleSheet w "buttons.css"++ buttons <- mkButtons+ getBody w #++ [UI.div #. "wrap" #+ (greet ++ map element buttons ++ [viewSource])]++greet :: [UI Element]+greet =+ [ UI.h1 #+ [string "Hello, Haskell!"]+ , UI.div #+ [string "Try the buttons below, they hover and click."]+ ]+++mkButton :: String -> UI (Element, Element)+mkButton title = do+ button <- UI.button #. "button" #+ [string title]+ view <- UI.p #+ [element button]+ return (button, view)++mkButtons :: UI [Element]+mkButtons = do+ list <- UI.ul #. "buttons-list"+ + (button1, view1) <- mkButton button1Title+ + on UI.hover button1 $ \_ -> do+ element button1 # set text (button1Title ++ " [hover]")+ on UI.leave button1 $ \_ -> do+ element button1 # set text button1Title+ on UI.click button1 $ \_ -> do+ element button1 # set text (button1Title ++ " [pressed]")+ liftIO $ threadDelay $ 1000 * 1000 * 1+ element list #+ [UI.li # set html "<b>Delayed</b> result!"]+ + (button2, view2) <- mkButton button2Title++ on UI.hover button2 $ \_ -> do+ element button2 # set text (button2Title ++ " [hover]")+ on UI.leave button2 $ \_ -> do+ element button2 # set text button2Title+ on UI.click button2 $ \_ -> do+ element button2 # set text (button2Title ++ " [pressed]")+ element list #+ [UI.li # set html "Zap! Quick result!"]+ + return [list, view1, view2]++ where button1Title = "Click me, I delay a bit"+ button2Title = "Click me, I work immediately"++viewSource :: UI Element+viewSource = UI.p #++ [UI.anchor #. "view-source" # set UI.href url #+ [string "View source code"]]+ where+ url = "https://github.com/HeinrichApfelmus/threepenny-gui/blob/master/src/Buttons.hs"+
+ samples/CRUD.hs view
@@ -0,0 +1,138 @@+{-----------------------------------------------------------------------------+ threepenny-gui+ + Example:+ Small database with CRUD operations and filtering.+ To keep things simple, the list box is rebuild every time+ that the database is updated. This is perfectly fine for rapid prototyping.+ A more sophisticated approach would use incremental updates.+------------------------------------------------------------------------------}+{-# LANGUAGE RecursiveDo #-}++import Prelude hiding (lookup)+import Control.Monad (void)+import Data.List (isPrefixOf)+import Data.Maybe+import Data.Monoid+import qualified Data.Map as Map+import qualified Data.Set as Set++import qualified Graphics.UI.Threepenny as UI+import Graphics.UI.Threepenny.Core hiding (delete)++{-----------------------------------------------------------------------------+ Main+------------------------------------------------------------------------------}+main :: IO ()+main = startGUI defaultConfig { tpPort = 10000 } setup++setup :: Window -> UI ()+setup window = void $ mdo+ return window # set title "CRUD Example (Simple)"++ -- GUI elements+ createBtn <- UI.button #+ [string "Create"]+ deleteBtn <- UI.button #+ [string "Delete"]+ listBox <- UI.listBox bListBoxItems bSelection bDisplayDataItem+ filterEntry <- UI.entry bFilterString+ ((firstname, lastname), tDataItem)+ <- dataItem bSelectionDataItem++ -- GUI layout+ element listBox # set (attr "size") "10" # set style [("width","200px")]+ + let uiDataItem = grid [[string "First Name:", element firstname]+ ,[string "Last Name:" , element lastname]]+ let glue = string " "+ getBody window #+ [grid+ [[row [string "Filter prefix:", element filterEntry], glue]+ ,[element listBox, uiDataItem]+ ,[row [element createBtn, element deleteBtn], glue]+ ]]++ -- events and behaviors+ bFilterString <- stepper "" . rumors $ UI.userText filterEntry+ let tFilter = isPrefixOf <$> UI.userText filterEntry+ bFilter = facts tFilter+ eFilter = rumors tFilter++ let eSelection = rumors $ UI.userSelection listBox+ eDataItemIn = rumors $ tDataItem+ eCreate = UI.click createBtn+ eDelete = UI.click deleteBtn++ -- database+ -- bDatabase :: Behavior (Database DataItem)+ let update' mkey x = flip update x <$> mkey+ bDatabase <- accumB emptydb $ concatenate <$> unions+ [ create ("Emil","Example") <$ eCreate+ , filterJust $ update' <$> bSelection <@> eDataItemIn+ , delete <$> filterJust (bSelection <@ eDelete)+ ]++ -- selection+ -- bSelection :: Behavior (Maybe DatabaseKey)+ bSelection <- stepper Nothing $ head <$> unions+ [ eSelection+ , Nothing <$ eDelete+ , Just . nextKey <$> bDatabase <@ eCreate+ , (\b s p -> b >>= \a -> if p (s a) then Just a else Nothing)+ <$> bSelection <*> bShowDataItem <@> eFilter+ ]+ + let bLookup :: Behavior (DatabaseKey -> Maybe DataItem)+ bLookup = flip lookup <$> bDatabase+ + bShowDataItem :: Behavior (DatabaseKey -> String)+ bShowDataItem = (maybe "" showDataItem .) <$> bLookup++ bDisplayDataItem = (UI.string .) <$> bShowDataItem+ + bListBoxItems :: Behavior [DatabaseKey]+ bListBoxItems = (\p show -> filter (p. show) . keys)+ <$> bFilter <*> bShowDataItem <*> bDatabase++ bSelectionDataItem :: Behavior (Maybe DataItem)+ bSelectionDataItem = (=<<) <$> bLookup <*> bSelection++ -- automatically enable / disable editing+ let+ bDisplayItem :: Behavior Bool+ bDisplayItem = maybe False (const True) <$> bSelection+ + element deleteBtn # sink UI.enabled bDisplayItem+ element firstname # sink UI.enabled bDisplayItem+ element lastname # sink UI.enabled bDisplayItem+++{-----------------------------------------------------------------------------+ Database Model+------------------------------------------------------------------------------}+type DatabaseKey = Int+data Database a = Database { nextKey :: !Int, db :: Map.Map DatabaseKey a }++emptydb = Database 0 Map.empty+keys = Map.keys . db++create x (Database newkey db) = Database (newkey+1) $ Map.insert newkey x db+update key x (Database newkey db) = Database newkey $ Map.insert key x db+delete key (Database newkey db) = Database newkey $ Map.delete key db+lookup key (Database _ db) = Map.lookup key db++{-----------------------------------------------------------------------------+ Data items that are stored in the data base+------------------------------------------------------------------------------}+type DataItem = (String, String)+showDataItem (firstname, lastname) = lastname ++ ", " ++ firstname++-- | Data item widget, consisting of two text entries+dataItem+ :: Behavior (Maybe DataItem)+ -> UI ((Element, Element), Tidings DataItem)+dataItem bItem = do+ entry1 <- UI.entry $ fst . maybe ("","") id <$> bItem+ entry2 <- UI.entry $ snd . maybe ("","") id <$> bItem+ + return ( (getElement entry1, getElement entry2)+ , (,) <$> UI.userText entry1 <*> UI.userText entry2+ )
+ samples/Chat.hs view
@@ -0,0 +1,106 @@+import Control.Concurrent+import qualified Control.Concurrent.Chan as Chan+import Control.Exception+import Control.Monad+import Data.Functor+import Data.List.Extra+import Data.Time+import Data.IORef+import Prelude hiding (catch)++import Paths++import qualified Graphics.UI.Threepenny as UI+import Graphics.UI.Threepenny.Core hiding (text)++{-----------------------------------------------------------------------------+ Chat+------------------------------------------------------------------------------}++main :: IO ()+main = do+ static <- getStaticDir+ messages <- Chan.newChan+ startGUI defaultConfig+ { tpPort = 10000+ , tpCustomHTML = Just "chat.html"+ , tpStatic = Just static+ } $ setup messages++type Message = (UTCTime, String, String)++setup :: Chan Message -> Window -> UI ()+setup globalMsgs window = do+ msgs <- liftIO $ Chan.dupChan globalMsgs++ return window # set title "Chat"+ + (nickRef, nickname) <- mkNickname+ messageArea <- mkMessageArea msgs nickRef++ getBody window #++ [ UI.div #. "header" #+ [string "Threepenny Chat"]+ , UI.div #. "gradient"+ , viewSource+ , element nickname+ , element messageArea+ ]+ + messageReceiver <- liftIO $ forkIO $ receiveMessages window msgs messageArea++ on UI.disconnect window $ const $ liftIO $ do+ 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+ atomic w $ runUI w $ do+ -- FIXME: withWindow should include a call to atomic ?+ element messageArea #+ [mkMessage msg]+ UI.scrollToBottom messageArea++mkMessageArea :: Chan Message -> IORef String -> UI Element+mkMessageArea msgs nickname = do+ input <- UI.textarea #. "send-textarea"+ + on UI.sendValue input $ (. trim) $ \content -> do+ element input # set value ""+ when (not (null content)) $ liftIO $ do+ now <- getCurrentTime+ nick <- readIORef nickname+ when (not (null nick)) $+ Chan.writeChan msgs (now,nick,content)++ UI.div #. "message-area" #+ [UI.div #. "send-area" #+ [element input]]+++mkNickname :: UI (IORef String, Element)+mkNickname = do+ input <- UI.input #. "name-input"+ el <- UI.div #. "name-area" #++ [ UI.span #. "name-label" #+ [string "Your name "]+ , element input+ ]+ UI.setFocus input+ + nick <- liftIO $ newIORef ""+ on UI.keyup input $ \_ -> liftIO . writeIORef nick . trim =<< get value input+ return (nick,el)++mkMessage :: Message -> UI Element+mkMessage (timestamp, nick, content) =+ UI.div #. "message" #++ [ UI.div #. "timestamp" #+ [string $ show timestamp]+ , UI.div #. "name" #+ [string $ nick ++ " says:"]+ , UI.div #. "content" #+ [string content]+ ]++viewSource :: UI Element+viewSource =+ UI.anchor #. "view-source" # set UI.href url #+ [string "View source code"]+ where+ url = "https://github.com/HeinrichApfelmus/threepenny-gui/blob/master/src/Chat.hs"
+ samples/CurrencyConverter.hs view
@@ -0,0 +1,40 @@+import Control.Monad (void)+import Data.Maybe+import Text.Printf+import Safe (readMay)++import qualified Graphics.UI.Threepenny as UI+import Graphics.UI.Threepenny.Core++{-----------------------------------------------------------------------------+ Main+------------------------------------------------------------------------------}+main :: IO ()+main = startGUI defaultConfig { tpPort = 10000 } setup++setup :: Window -> UI ()+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 . readMay+ + dollarOut = withString (/ rate) <$> euroIn+ euroOut = withString (* rate) <$> dollarIn+ + element euro # sink value euroOut+ element dollar # sink value dollarOut+
+ samples/Data/List/Extra.hs view
@@ -0,0 +1,8 @@+module Data.List.Extra where+ +import Data.List+import Data.Char+import Data.Maybe++trim :: String -> String+trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace
+ samples/DragNDropExample.hs view
@@ -0,0 +1,66 @@+import Control.Applicative+import Control.Monad+import Data.IORef+import Data.Maybe++import Paths++import qualified Graphics.UI.Threepenny as UI+import Graphics.UI.Threepenny.Core++{-----------------------------------------------------------------------------+ Drag'N'Drop example+------------------------------------------------------------------------------}+main :: IO ()+main = do+ static <- getStaticDir+ startGUI defaultConfig+ { tpPort = 10000+ , tpStatic = Just static+ } setup++setup :: Window -> UI ()+setup w = void $ do+ return w # set title "Drag 'N' Drop Example"+ UI.addStyleSheet w "DragNDropExample.css"+ + pairs <- sequence $+ zipWith mkDragPair (words "red green blue") (map (150*) [0..2])+ getBody w #+ concat [[element i, element o] | (i,o) <- pairs]++type Color = String++mkDragPair :: Color -> Int -> UI (Element, Element)+mkDragPair color position = do+ elDrag <- UI.new #. "box-drag"+ # set UI.style [("left", show position ++ "px"), ("color",color)]+ # set text "Drag me!"+ # set UI.draggable True+ # set UI.dragData color++ elDrop <- UI.new #. "box-drop"+ # set UI.style [("border","2px solid " ++ color), ("left", show position ++ "px")]+++ dropSuccess <- liftIO $ newIORef False++ on UI.dragStart elDrag $ \_ -> void $+ element elDrop+ # set text "Drop here!"+ # set UI.droppable True+ on UI.dragEnd elDrag $ \_ -> void $ do+ dropped <- liftIO $ readIORef dropSuccess+ when (not dropped) $ void $+ element elDrop+ # set text ""+ # set UI.droppable False++ on UI.drop elDrop $ \color' -> when (color == color') $ void $ do+ liftIO $ writeIORef dropSuccess True+ delete elDrag+ element elDrop+ # set text "Dropped!"+ # set UI.droppable False+ + return (elDrag, elDrop)+
+ samples/DrumMachine.hs view
@@ -0,0 +1,93 @@+import Control.Monad+import Data.IORef+import Data.Functor++import Paths+import System.FilePath++import qualified Graphics.UI.Threepenny as UI+import Graphics.UI.Threepenny.Core++{-----------------------------------------------------------------------------+ Configuration+------------------------------------------------------------------------------}+bars = 4+beats = 4+defaultBpm = 120++bpm2ms :: Int -> Int+bpm2ms bpm = ceiling $ 1000*60 / fromIntegral bpm++-- NOTE: Samples taken from "conductive-examples"++instruments = words "kick snare hihat"++loadInstrumentSample name = do+ static <- liftIO $ getStaticDir+ loadFile "audio/wav" (static </> name <.> "wav")++{-----------------------------------------------------------------------------+ Main+------------------------------------------------------------------------------}+main :: IO ()+main = startGUI defaultConfig { tpPort = 10000 } setup++setup :: Window -> UI ()+setup w = void $ do+ return w # set title "Ha-ha-ha-ks-ks-ks-ha-ha-ha-ell-ell-ell"++ elBpm <- UI.input # set value (show defaultBpm)+ elTick <- UI.span+ (kit, elInstruments) <- mkDrumKit+ let status = grid [[UI.string "BPM:" , element elBpm]+ ,[UI.string "Beat:", element elTick]]+ getBody w #+ [UI.div #. "wrap" #+ (status : map element elInstruments)]+ + timer <- UI.timer # set UI.interval (bpm2ms defaultBpm)+ eBeat <- accumE (0::Int) $+ (\beat -> (beat + 1) `mod` (beats * bars)) <$ UI.tick timer+ onEvent 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 UI.keydown elBpm $ \keycode -> when (keycode == 13) $ void $ do+ bpm <- read <$> get value elBpm+ return timer # set UI.interval (bpm2ms bpm)+ + -- star the timer+ UI.start timer+++type Kit = [Instrument]+type Instrument = [Beat]+type Beat = UI () -- play the corresponding sound++mkDrumKit :: UI (Kit, [Element])+mkDrumKit = unzip <$> mapM mkInstrument instruments++mkInstrument :: String -> UI (Instrument, Element)+mkInstrument name = do+ elCheckboxes <-+ sequence $ replicate bars $+ sequence $ replicate beats $+ UI.input # set UI.type_ "checkbox"++ url <- loadInstrumentSample name+ elAudio <- UI.audio # set (attr "preload") "1" # set UI.src url++ let play box = do+ checked <- get UI.checked box+ 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]+ + elInstrument <- UI.div #. "instrument"+ #+ (element elAudio : UI.string name : elGroups)+ + return (beats, elInstrument)+
+ samples/MissingDollars.hs view
@@ -0,0 +1,134 @@+import Control.Monad+import Safe++import Paths++import qualified Graphics.UI.Threepenny as UI+import Graphics.UI.Threepenny.Core++{-----------------------------------------------------------------------------+ Missing Dollars+------------------------------------------------------------------------------}+main :: IO ()+main = do+ static <- getStaticDir+ startGUI defaultConfig+ { tpPort = 10000+ , tpStatic = Just static+ } setup+++setup :: Window -> UI ()+setup w = void $ do+ return w # set title "Missing Dollars"+ UI.addStyleSheet w "missing-dollars.css"+ + (headerView,headerMe) <- mkHeader+ riddle <- mkMissingDollarRiddle headerMe+ let layout = [element headerView] ++ riddle ++ attributionSource + getBody w #+ [UI.div #. "wrap" #+ layout]+++mkHeader :: UI (Element, Element)+mkHeader = do+ headerMe <- string "..."+ view <- UI.h1 #+ [string "The ", element headerMe, string " Dollars"]+ return (view, headerMe)++attributionSource :: [UI Element]+attributionSource =+ [ UI.p #++ [ UI.anchor #. "view-source" # set UI.href urlSource+ #+ [string "View source code"]+ ]+ , UI.p #++ [ string "Originally by "+ , UI.anchor # set UI.href urlAttribution #+ [string "Albert Lai"]+ ]+ ]+ where+ urlSource = "https://github.com/HeinrichApfelmus/threepenny-gui/blob/master/src/MissingDollars.hs"+ urlAttribution = "http://www.vex.net/~trebla/humour/missing_dollar.html"+++mkMissingDollarRiddle :: Element -> UI [UI Element]+mkMissingDollarRiddle headerMe = do+ -- declare input and display values+ (hotelOut : hotelCost : hotelHold : _)+ <- sequence . replicate 3 $+ UI.input # set (attr "size") "3" # set (attr "type") "text"++ (hotelChange : hotelRet : hotelBal : hotelPocket :+ hotelBal2 : hotelPocket2 : hotelSum : hotelMe : _)+ <- sequence . replicate 8 $ UI.span+ + -- update procedure+ let updateDisplay out cost hold = do+ let change = out - cost+ ret = change - hold+ bal = out - ret+ sum = bal + hold+ diff = sum - out+ element hotelOut # set value (show out)+ element hotelCost # set value (show cost)+ element hotelHold # set value (show hold)+ element hotelChange # set text (show change)+ element hotelRet # set text (show ret)+ element hotelBal # set text (show bal)+ element hotelPocket # set text (show hold)+ element hotelBal2 # set text (show bal)+ element hotelPocket2 # set text (show hold)+ element hotelSum # set text (show sum)+ + if diff >= 0+ then do element hotelMe # set text ("extra $" ++ show diff ++ " come from")+ element headerMe # set text "Extra"+ else do element hotelMe # set text ("missing $" ++ show (-diff) ++ " go")+ element headerMe # set text "Missing"+ return ()+ + -- initialize values+ updateDisplay 30 25 2+ + -- calculate button+ calculate <- UI.button #+ [string "Calculate"]+ on UI.click calculate $ \_ -> do+ result <- mapM readMay `liftM` getValuesList [hotelOut,hotelCost,hotelHold]+ case result of+ Just [getout,getcost,gethold] -> updateDisplay getout getcost gethold+ _ -> return ()+ + return $+ [ UI.h2 #+ [string "The Guests, The Bellhop, And The Pizza"]+ , UI.p #++ [ string "Three guests went to a hotel and gave $"+ , element hotelOut+ , string " to the bellhop to buy pizza. The pizza cost only $"+ , element hotelCost+ , string ". Of the $"+ , element hotelChange+ , string " change, the bellhop kept $"+ , element hotelHold+ , string " to himself and returned $"+ , element hotelRet+ , string " to the guests."+ ]+ , UI.p #++ [ string "So the guests spent $"+ , element hotelBal+ , string ", and the bellhop pocketed $"+ , element hotelPocket+ , string ". Now "+ , string "$"+ , element hotelBal2+ , string "+$"+ , element hotelPocket2+ , string "=$"+ , element hotelSum+ , string ". Where did the "+ , element hotelMe+ , string "?"+ ]+ , element calculate+ ] +
+ samples/Paths.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE CPP#-}+module Paths (getStaticDir) where++import Control.Monad+import System.FilePath++#if CABAL+-- using cabal+import qualified Paths_threepenny_gui (getDataDir)++getStaticDir :: IO FilePath+getStaticDir = (</> "wwwroot") `liftM` Paths_threepenny_gui.getDataDir++#else+-- using GHCi++getStaticDir :: IO FilePath+getStaticDir = return "../wwwroot/"++#endif
+ samples/Tidings.hs view
@@ -0,0 +1,37 @@+module Tidings (+ -- * Synopsis+ -- The 'Tidings' data type for composing user events.+ --+ -- See <http://apfelmus.nfshost.com/blog/2012/03/29-frp-three-principles-bidirectional-gui.html>+ -- for more information.+ + -- * Documentation+ Tidings, tidings, facts, rumors,+ ) where++import Reactive.Threepenny++-- | Data type representing a behavior 'facts'+-- and suggestions to change it 'rumors'.+data Tidings a = T { facts :: Behavior a, rumors :: Event a }++-- | Smart constructor. Combine facts and rumors into 'Tidings'.+tidings :: Behavior a -> Event a -> Tidings a+tidings b e = T b e++instance Functor Tidings where+ fmap f (T b e) = T (fmap f b) (fmap f e)++-- | The applicative instance combines 'rumors'+-- and uses 'facts' when some of the 'rumors' are not available.+instance Applicative Tidings where+ pure x = T (pure x) never+ f <*> x = uncurry ($) <$> pair f x++pair :: Tidings a -> Tidings b -> Tidings (a,b)+pair (T bx ex) (T by ey) = T b e+ where+ b = (,) <$> bx <*> by+ x = flip (,) <$> by <@> ex+ y = (,) <$> bx <@> ey+ e = unionWith (\(x,_) (_,y) -> (x,y)) x y
+ samples/UseWords.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE ViewPatterns #-}++import Control.Applicative hiding ((<|>),many)+import Control.Monad+import Control.Arrow (second)+import Data.Maybe+import Text.Parsec+import System.FilePath ((</>))++import qualified Graphics.UI.Threepenny as UI+import Graphics.UI.Threepenny.Core hiding (string, (<|>), many)+import Paths++{-----------------------------------------------------------------------------+ GUI+------------------------------------------------------------------------------}+main :: IO ()+main = do+ static <- getStaticDir+ startGUI defaultConfig+ { tpPort = 10000+ , tpStatic = Just static+ } setup+++setup :: Window -> UI ()+setup w = do+ filename <- liftIO $ fmap (</> "and-then-haskell.txt") getStaticDir + andthen <- liftIO $ readFile filename+ case parts filename andthen of+ Left parseerror -> debug $ show parseerror+ Right parts -> void $ do+ UI.addStyleSheet w "use-words.css"++ let (header, Prelude.drop 2 -> rest) = splitAt 3 parts + + (views1, vars1) <- renderParts header+ (views2, vars2) <- renderParts rest+ varChoices <- mapM (renderVarChoice (vars1 ++ vars2)) vars+ + getBody w #++ [ viewSource+ , UI.div #. "wrap" #+ (+ [ UI.div #. "header" #+ map element views1+ , UI.ul #. "vars" #+ map element varChoices+ ]+ ++ map element views2 )+ ]+ +type VariableViews = [(Name, Element)]++renderVarChoice :: VariableViews -> Variable -> UI Element+renderVarChoice views (label,(name,def)) = do+ input <- UI.input #. "var-value" # set value def+ + on (domEvent "livechange") input $ \(EventData xs) -> do+ let s = concat $ catMaybes xs+ forM_ (filter ((==name).fst) views) $ \(_,el) -> do+ element el # set text s+ + UI.li #+ [UI.string (label ++ ":"), element input]++renderParts :: [Part] -> UI ([Element], VariableViews)+renderParts parts = do+ views <- mapM renderPart parts+ let variables = [(var, view) | (Ref var, view) <- zip parts views]+ return (views, variables)++renderPart :: Part -> UI Element+renderPart (Text str) = UI.div #. "text" #+ [UI.string str]+renderPart (Ref var) = UI.div #. "var"+ # maybe (set text $ "{" ++ var ++ "}") (either (set html) (set text))+ (lookup var templatevars)++viewSource :: UI Element+viewSource = UI.p #++ [UI.anchor #. "view-source" # set UI.href url #+ [UI.string "View source code"]]+ where+ url = "https://github.com/HeinrichApfelmus/threepenny-gui/blob/master/src/UseWords.hs"++{-----------------------------------------------------------------------------+ Parsing+------------------------------------------------------------------------------}+type Name = String+type Variable = (String, (Name, String))++templatevars = map (second Right . snd) vars ++ map (second Left) exts++vars :: [Variable]+vars = [("Favourite technology",("favourite-language","Haskell"))+ ,("Technology used at work",("work-language","Python"))+ ,("Cool forum",("bar","LtU"))+ ,("Particular to technology",("particular-stuff","monads"))]+exts = [("br","<br><br>")]++data Part = Text String | Ref String deriving Show++parts :: SourceName -> String -> Either ParseError [Part]+parts = parse (many (ref <|> text)) where+ text = Text <$> many1 (notFollowedBy (string "{") *> anyChar)+ ref = Ref <$> (string "{" *> many1 (noneOf "}") <* (string "}"))
− src/BarTab.hs
@@ -1,86 +0,0 @@-{-# LANGUAGE CPP, PackageImports #-}-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}--import Control.Applicative-import Control.Monad-import Data.IORef-import Data.Maybe--import Paths--#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 entry point. Starts a TP server.-main :: IO ()-main = do- static <- getStaticDir- startGUI defaultConfig- { tpPort = 10000- , tpStatic = Just static- } setup--setup :: Window -> IO ()-setup w = do- -- active elements- return w # set title "BarTab"-- elAdd <- UI.button # set UI.text "Add"- elRemove <- UI.button # set UI.text "Remove"- elResult <- UI.span-- inputs <- newIORef []- - -- functionality- let- displayTotal = void $ do- xs <- getValuesList =<< readIORef inputs- element elResult # set text (showNumber . sum $ map readNumber xs)- - redoLayout :: IO ()- redoLayout = void $ do- layout <- mkLayout =<< readIORef inputs- getBody w # set children [layout]- displayTotal-- mkLayout :: [Element] -> IO Element- mkLayout xs = column $- [row [element elAdd, element elRemove]- ,UI.hr]- ++ map element xs ++- [UI.hr- ,row [UI.span # set text "Sum: ", element elResult]- ]- - addInput :: IO ()- addInput = do- elInput <- UI.input # set value "0"- on (domEvent "livechange") elInput $ \_ -> displayTotal- modifyIORef inputs (elInput:)- - on UI.click elAdd $ \_ -> addInput >> redoLayout- on UI.click elRemove $ \_ -> modifyIORef inputs (drop 1) >> redoLayout- addInput >> redoLayout---{------------------------------------------------------------------------------ Functionality-------------------------------------------------------------------------------}-type Number = Maybe Double--instance Num Number where- (+) = liftA2 (+)- (-) = liftA2 (-)- (*) = liftA2 (*)- abs = fmap abs- signum = fmap signum- fromInteger = pure . fromInteger--readNumber :: String -> Number-readNumber s = listToMaybe [x | (x,"") <- reads s] -showNumber = maybe "--" show
− src/Buttons.hs
@@ -1,84 +0,0 @@-{-# LANGUAGE CPP, PackageImports #-}--import Control.Monad-import Control.Concurrent (threadDelay)--#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-import Paths--{------------------------------------------------------------------------------ Buttons-------------------------------------------------------------------------------}--main :: IO ()-main = do- static <- getStaticDir- startGUI defaultConfig- { tpPort = 10000- , tpStatic = Just static- } setup--setup :: Window -> IO ()-setup w = void $ do- return w # set title "Buttons"- UI.addStyleSheet w "buttons.css"-- buttons <- mkButtons- getBody w #+- [UI.div #. "wrap" #+ (greet ++ map element buttons ++ [viewSource])]--greet :: [IO Element]-greet =- [ UI.h1 #+ [string "Hello, Haskell!"]- , UI.div #+ [string "Try the buttons below, they hover and click."]- ]---mkButton :: String -> IO (Element, Element)-mkButton title = do- button <- UI.button #. "button" #+ [string title]- view <- UI.p #+ [element button]- return (button, view)--mkButtons :: IO [Element]-mkButtons = do- list <- UI.ul #. "buttons-list"- - (button1, view1) <- mkButton button1Title- - on UI.hover button1 $ \_ -> do- element button1 # set text (button1Title ++ " [hover]")- on UI.leave button1 $ \_ -> do- element button1 # set text button1Title- on UI.click button1 $ \_ -> do- element button1 # set text (button1Title ++ " [pressed]")- threadDelay $ 1000 * 1000 * 1- element list #+ [UI.li # set html "<b>Delayed</b> result!"]- - (button2, view2) <- mkButton button2Title-- on UI.hover button2 $ \_ -> do- element button2 # set text (button2Title ++ " [hover]")- on UI.leave button2 $ \_ -> do- element button2 # set text button2Title- on UI.click button2 $ \_ -> do- element button2 # set text (button2Title ++ " [pressed]")- element list #+ [UI.li # set html "Zap! Quick result!"]- - return [list, view1, view2]-- where button1Title = "Click me, I delay a bit"- button2Title = "Click me, I work immediately"--viewSource :: IO Element-viewSource = UI.p #+- [UI.anchor #. "view-source" # set UI.href url #+ [string "View source code"]]- where- url = "https://github.com/HeinrichApfelmus/threepenny-gui/blob/master/src/Buttons.hs"-
− src/Chat.hs
@@ -1,116 +0,0 @@-{-# LANGUAGE CPP, PackageImports #-}-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}--import Control.Concurrent-import qualified Control.Concurrent.Chan as Chan-import Control.Exception-import Control.Monad-import Data.Functor-import Data.List.Extra-import Data.Time-import Data.IORef-import Prelude hiding (catch)--import Control.Monad.Trans.Reader as Reader-import Control.Monad.IO.Class--#ifdef CABAL-import qualified "threepenny-gui" Graphics.UI.Threepenny as UI-import "threepenny-gui" Graphics.UI.Threepenny.Core hiding (text)-#else-import qualified Graphics.UI.Threepenny as UI-import Graphics.UI.Threepenny.Core hiding (text)-#endif-import Paths--{------------------------------------------------------------------------------ Chat-------------------------------------------------------------------------------}--main :: IO ()-main = do- static <- getStaticDir- messages <- Chan.newChan- startGUI defaultConfig- { tpPort = 10000- , tpCustomHTML = Just "chat.html"- , tpStatic = Just static- } $ setup messages--type Message = (UTCTime, String, String)--setup :: Chan Message -> Window -> IO ()-setup globalMsgs window = do- msgs <- Chan.dupChan globalMsgs-- return window # set title "Chat"- - (nickRef, nickname) <- mkNickname- messageArea <- mkMessageArea msgs nickRef-- getBody window #+- [ UI.div #. "header" #+ [string "Threepenny Chat"]- , UI.div #. "gradient"- , viewSource- , element nickname- , element messageArea- ]- - messageReceiver <- forkIO $ receiveMessages window msgs messageArea-- on UI.disconnect window $ const $ do- putStrLn "Disconnected!"- killThread messageReceiver- now <- getCurrentTime- nick <- readIORef nickRef- Chan.writeChan msgs (now,nick,"( left the conversation )")---receiveMessages w msgs messageArea = do- messages <- Chan.getChanContents msgs- forM_ messages $ \msg -> do- atomic w $ do- element messageArea #+ [mkMessage msg]- UI.scrollToBottom messageArea--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 <- readIORef nickname- element input # set value ""- when (not (null nick)) $- Chan.writeChan msgs (now,nick,content)-- UI.div #. "message-area" #+ [UI.div #. "send-area" #+ [element input]]---mkNickname :: IO (IORef String, Element)-mkNickname = do- 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) =- UI.div #. "message" #+- [ UI.div #. "timestamp" #+ [string $ show timestamp]- , UI.div #. "name" #+ [string $ nick ++ " says:"]- , UI.div #. "content" #+ [string content]- ]--viewSource :: IO Element-viewSource =- UI.anchor #. "view-source" # set UI.href url #+ [string "View source code"]- where- url = "https://github.com/HeinrichApfelmus/threepenny-gui/blob/master/src/Chat.hs"
− src/CurrencyConverter.hs
@@ -1,52 +0,0 @@-{------------------------------------------------------------------------------ threepenny-gui- - Example: Currency Converter-------------------------------------------------------------------------------}-{-# LANGUAGE CPP, PackageImports #-}--import Control.Monad (void)-import Data.Maybe-import Text.Printf-import Safe (readMay)--#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 . readMay- - dollarOut = withString (/ rate) <$> euroIn- euroOut = withString (* rate) <$> dollarIn- - element euro # sink value euroOut- element dollar # sink value dollarOut-
− src/Data/List/Extra.hs
@@ -1,8 +0,0 @@-module Data.List.Extra where- -import Data.List-import Data.Char-import Data.Maybe--trim :: String -> String-trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace
− src/DragNDropExample.hs
@@ -1,72 +0,0 @@-{-# LANGUAGE CPP, PackageImports #-}--import Control.Applicative-import Control.Monad-import Data.IORef-import Data.Maybe--#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-import Paths--{------------------------------------------------------------------------------ Drag'N'Drop example-------------------------------------------------------------------------------}-main :: IO ()-main = do- static <- getStaticDir- startGUI defaultConfig- { tpPort = 10000- , tpStatic = Just static- } setup--setup :: Window -> IO ()-setup w = void $ do- return w # set title "Drag 'N' Drop Example"- UI.addStyleSheet w "DragNDropExample.css"- - pairs <- sequence $- zipWith (mkDragPair w) (words "red green blue") (map (150*) [0..2])- getBody w #+ concat [[element i, element o] | (i,o) <- pairs]--type Color = String--mkDragPair :: Window -> Color -> Int -> IO (Element, Element)-mkDragPair w color position = do- elDrag <- UI.new #. "box-drag"- # set UI.style [("left", show position ++ "px"), ("color",color)]- # set text "Drag me!"- # set UI.draggable True- # set UI.dragData color-- elDrop <- UI.new #. "box-drop"- # set UI.style [("border","2px solid " ++ color), ("left", show position ++ "px")]--- dropSuccess <- newIORef False-- on UI.dragStart elDrag $ \_ -> void $- element elDrop- # set text "Drop here!"- # set UI.droppable True- on UI.dragEnd elDrag $ \_ -> void $ do- dropped <- readIORef dropSuccess- when (not dropped) $ void $- element elDrop- # set text ""- # set UI.droppable False-- on UI.drop elDrop $ \color' -> when (color == color') $ void $ do- writeIORef dropSuccess True- delete elDrag- element elDrop- # set text "Dropped!"- # set UI.droppable False- - return (elDrag, elDrop)-
− src/DrumMachine.hs
@@ -1,105 +0,0 @@-{-# LANGUAGE CPP, PackageImports #-}--import Control.Monad-import Data.IORef-import Data.Functor--#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-import Paths-import System.FilePath--{------------------------------------------------------------------------------ Configuration-------------------------------------------------------------------------------}-bars = 4-beats = 4-defaultBpm = 120--bpm2ms :: Int -> Int-bpm2ms bpm = ceiling $ 1000*60 / fromIntegral bpm---- NOTE: Samples taken from "conductive-examples"--instruments = words "kick snare hihat"--loadInstrumentSample w name = do- static <- getStaticDir- loadFile w "audio/wav" (static </> name <.> "wav")--{------------------------------------------------------------------------------ Main-------------------------------------------------------------------------------}-main :: IO ()-main = do- static <- getStaticDir- startGUI defaultConfig- { tpPort = 10000- , tpStatic = Just static- } setup--setup :: Window -> IO ()-setup w = void $ do- return w # set title "Ha-ha-ha-ks-ks-ks-ha-ha-ha-ell-ell-ell"-- elBpm <- UI.input # set value (show defaultBpm)- elTick <- UI.span- (kit, elInstruments) <- mkDrumKit w- let status = grid [[UI.string "BPM:" , element elBpm]- ,[UI.string "Beat:", element elTick]]- getBody w #+ [UI.div #. "wrap" #+ (status : map element elInstruments)]- - 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 UI.keydown elBpm $ \keycode -> when (keycode == 13) $ void $ do- bpm <- read <$> get value elBpm- return timer # set UI.interval (bpm2ms bpm)- - -- star the timer- UI.start timer---type Kit = [Instrument]-type Instrument = [Beat]-type Beat = IO () -- play the corresponding sound--mkDrumKit :: Window -> IO (Kit, [Element])-mkDrumKit w = unzip <$> mapM (mkInstrument w) instruments--mkInstrument :: Window -> String -> IO (Instrument, Element)-mkInstrument window name = do- elCheckboxes <-- sequence $ replicate bars $- sequence $ replicate beats $- UI.input # set UI.type_ "checkbox"-- url <- loadInstrumentSample window name- elAudio <- UI.audio # set (attr "preload") "1" # set UI.src url-- let- play box = do- checked <- get UI.checked box- 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]- - elInstrument <- UI.div #. "instrument"- #+ (element elAudio : UI.string name : elGroups)- - return (beats, elInstrument)-
+ src/Foreign/Coupon.hs view
@@ -0,0 +1,181 @@+{-# LANGUAGE RecordWildCards, CPP #-}+{-# LANGUAGE MagicHash, UnboxedTuples #-}+module Foreign.Coupon (+ -- * Synopsis+ -- | References to remote objects.+ -- Offers unique tokens ('Coupon') for communication.+ -- Supports garbage collection and finalizers.+ + -- * Documentation+ Coupon,+ PrizeBooth, newPrizeBooth, lookup,+ + Item, newItem, withItem,+ addFinalizer, destroy, addReachable, clearReachable,+ ) where++import Prelude hiding (lookup)+import Control.Concurrent+import Control.Monad+import Control.Exception (evaluate)++import qualified Data.ByteString.Char8 as BS+import Data.Functor+import Data.IORef+import qualified Data.Map as Map++import System.Mem.Weak hiding (addFinalizer)+import qualified System.Mem.Weak as Weak++import qualified GHC.Base as GHC+import qualified GHC.Weak as GHC+import qualified GHC.IORef as GHC+import qualified GHC.STRef as GHC++mkWeakIORefValue :: IORef a -> value -> IO () -> IO (Weak value)+mkWeakIORefValue r@(GHC.IORef (GHC.STRef r#)) v f = GHC.IO $ \s ->+ case GHC.mkWeak# r# v f s of (# s1, w #) -> (# s1, GHC.Weak w #)++#if CABAL+#if MIN_VERSION_base(4,6,0)+#else+atomicModifyIORef' = atomicModifyIORef+#endif+#endif++debug m = m+-- debug m = return ()++type Map = Map.Map++{-----------------------------------------------------------------------------+ Types+------------------------------------------------------------------------------}+-- | Coupons can be used as a proxy for 'Item'.+--+-- The important point is that coupons can be serialized and sent+-- over a remote connection.+--+-- Coupons are in bijection with items:+-- Different coupons will yield different items while+-- the same item will always be associated to the same coupon.+type Coupon = BS.ByteString++-- | Items represent foreign objects.+-- The intended use case is that these objects do not live in RAM,+-- but are only accessible via a remote connection.+-- +-- The foreign object can be accessed by means of the item data of type @a@.+type Item a = IORef (ItemData a)++data ItemData a = ItemData+ { self :: Weak (Item a)+ , coupon :: Coupon+ , value :: a+ , children :: IORef [Weak (Item a)]+ }+++-- | Remote boothes are a mapping from 'Coupon' to 'Item'.+--+-- Prize boothes are neutral concerning garbage collection,+-- they do not keep items alive.+-- Moreover, items will be deleted from the booth when they are garbage collected.+data PrizeBooth a = PrizeBooth+ { bCoupons :: MVar (Map Coupon (Weak (Item a)))+ , bCounter :: MVar [Integer]+ }++{-----------------------------------------------------------------------------+ Booth and Coupons+------------------------------------------------------------------------------}+-- | Create a new prize booth for creating items and trading coupons.+newPrizeBooth :: IO (PrizeBooth a)+newPrizeBooth = do+ bCounter <- newMVar [0..]+ bCoupons <- newMVar Map.empty+ return $ PrizeBooth {..}++-- | Take a coupon to the prize booth and maybe you'll get an item for it.+lookup :: Coupon -> PrizeBooth a -> IO (Maybe (Item a))+lookup coupon PrizeBooth{..} = do+ w <- Map.lookup coupon <$> readMVar bCoupons+ maybe (return Nothing) deRefWeak w++-- | Create a new item, which can be exchanged for a coupon+-- at an associated prize booth.+--+-- The item can become unreachable,+-- at which point it will be garbage collected,+-- the finalizers will be run and its+-- coupon ceases to be valid.+newItem :: PrizeBooth a -> a -> IO (Item a)+newItem PrizeBooth{..} value = do+ coupon <- BS.pack . show <$> modifyMVar bCounter (\(n:ns) -> return (ns,n))+ children <- newIORef []+ let self = undefined+ item <- newIORef ItemData{..}+ + let finalize = modifyMVar bCoupons $ \m -> return (Map.delete coupon m, ())+ w <- mkWeakIORef item finalize+ modifyMVar bCoupons $ \m -> return (Map.insert coupon w m, ())+ atomicModifyIORef' item $ \itemdata -> (itemdata { self = w }, ())+ return item++{-----------------------------------------------------------------------------+ Items+------------------------------------------------------------------------------}+-- | Perform an action with the item.+-- +-- While the action is being performed, it is ensured that the item+-- will not be garbage collected+-- and its coupon can be succesfully redeemed at the prize booth.+withItem :: Item a -> (Coupon -> a -> IO b) -> IO b+withItem item f = do+ ItemData{..} <- readIORef item+ b <- f coupon value+ touchItem item+ return b++-- | Make Sure that the item in question is alive+-- at the given place in the sequence of IO actions.+touchItem :: Item a -> IO ()+touchItem item = item `seq` return ()++-- | Destroy an item and run all finalizers for it.+-- Coupons for this item can no longer be redeemed.+destroy :: Item a -> IO ()+destroy item = finalize =<< self <$> readIORef item++-- | Add a finalizer that is run when the item is garbage collected.+--+-- The coupon cannot be redeemed anymore while the finalizer runs.+addFinalizer :: Item a -> IO () -> IO ()+addFinalizer item = void . mkWeakIORef item++-- | When dealing with several foreign objects,+-- it is useful to model dependencies between them.+--+-- After this operation, the second 'Item' will be reachable+-- whenever the first one is reachable.+-- For instance, you should call this function when the second foreign object+-- is actually a subobject of the first one.+--+-- Note: It is possible to model dependencies in the @parent@ data,+-- but the 'addReachable' method is preferrable,+-- as it allows all child object to be garbage collected at once.+addReachable :: Item a -> Item a -> IO ()+addReachable parent child = do+ w <- mkWeakIORefValue parent child $ return ()+ ref <- children <$> readIORef parent+ atomicModifyIORef' ref $ \ws -> (w:ws, ())++-- | Clear all dependencies.+-- +-- Reachability of this 'Item' no longer implies reachability+-- of other items, as formerly implied by calls to 'addReachable'.+clearReachable :: Item a -> IO ()+clearReachable item = do+ ref <- children <$> readIORef item+ xs <- atomicModifyIORef' ref $ \xs -> ([], xs)+ mapM_ finalize xs
src/Graphics/UI/Threepenny.hs view
@@ -14,6 +14,7 @@ module Graphics.UI.Threepenny.Events, module Graphics.UI.Threepenny.JQuery, module Graphics.UI.Threepenny.Timer,+ module Graphics.UI.Threepenny.Widgets, ) where import Graphics.UI.Threepenny.Attributes@@ -24,6 +25,7 @@ import Graphics.UI.Threepenny.Events import Graphics.UI.Threepenny.JQuery import Graphics.UI.Threepenny.Timer+import Graphics.UI.Threepenny.Widgets {- $intro @@ -68,7 +70,7 @@ the following function will be executed to start the GUI interaction. It builds the initial HTML page. -> setup :: Window -> IO ()+> setup :: Window -> UI () > setup window = do First, set the title of the HTML document@@ -99,7 +101,7 @@ 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>.+<https://github.com/HeinrichApfelmus/threepenny-gui#examples plethora of additional example code>. -}
src/Graphics/UI/Threepenny/Canvas.hs view
@@ -8,8 +8,6 @@ ) where import Graphics.UI.Threepenny.Core-import qualified Graphics.UI.Threepenny.Internal.Core as Core-import qualified Graphics.UI.Threepenny.Internal.Types as Core {----------------------------------------------------------------------------- Canvas@@ -19,16 +17,12 @@ type Vector = (Int,Int) -- | Draw the image of an image element onto the canvas at a specified position.-drawImage :: Element -> Vector -> Canvas -> IO ()-drawImage eimage (x,y) = updateElement $ \(Core.Element canvas window) -> do- image <- manifestElement window eimage- runFunction window $- ffi "%1.getContext('2d').drawImage(%2,%3,%4)" canvas image x y+drawImage :: Element -> Vector -> Canvas -> UI ()+drawImage image (x,y) canvas =+ runFunction $ ffi "%1.getContext('2d').drawImage(%2,%3,%4)" canvas image x y -- | Clear the canvas-clearCanvas :: Canvas -> IO ()-clearCanvas = updateElement $ \(Core.Element canvas window) -> do- runFunction window $- ffi "%1.getContext('2d').clear()" canvas+clearCanvas :: Canvas -> UI ()+clearCanvas = runFunction . ffi "%1.getContext('2d').clear()"
src/Graphics/UI/Threepenny/Core.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE DeriveDataTypeable, RecordWildCards #-}+{-# LANGUAGE RecursiveDo #-} module Graphics.UI.Threepenny.Core ( -- * Synopsis -- | Core functionality of the Threepenny GUI library.@@ -8,6 +9,12 @@ Config(..), defaultConfig, startGUI, loadFile, loadDirectory, + -- * UI monad+ -- $ui+ UI, runUI, askWindow, liftIOLater,+ module Control.Monad.IO.Class,+ module Control.Monad.Fix,+ -- * Browser Window Window, title, cookies, getRequestLocation, @@ -17,9 +24,7 @@ getHead, getBody, children, text, html, attr, style, value, getValuesList,- getElementsByTagName, getElementByTagName, - getElementsById, getElementById,- getElementsByClassName,+ getElementsByTagName, getElementById, getElementsByClassName, -- * Layout -- | Combinators for quickly creating layouts.@@ -28,23 +33,26 @@ -- * Events -- | For a list of predefined events, see "Graphics.UI.Threepenny.Events".- EventData(..), domEvent, on, disconnect,+ EventData(..), domEvent, disconnect, on, onEvent, onChanges, module Reactive.Threepenny, -- * Attributes -- | For a list of predefined attributes, see "Graphics.UI.Threepenny.Attributes".- (#), (#.), element,+ (#), (#.), Attr, WriteAttr, ReadAttr, ReadWriteAttr(..), set, sink, get, mkReadWriteAttr, mkWriteAttr, mkReadAttr, + -- * Widgets+ Widget(..), element, widget,+ -- * JavaScript FFI -- | Direct interface to JavaScript in the browser window.- debug, clear,+ debug, ToJS, FFI, ffi, JSFunction, runFunction, callFunction, callDeferredFunction, atomic, -- * Internal and oddball functions- updateElement, manifestElement, fromProp,+ fromProp, toElement, audioPlay, audioStop, ) where@@ -55,22 +63,32 @@ import Data.Maybe (listToMaybe) import Data.Functor import Data.String (fromString)+ import Control.Concurrent.MVar import Control.Monad+import Control.Monad.Fix import Control.Monad.IO.Class+import qualified Control.Monad.Trans.RWS.Lazy as Monad+ import Network.URI import Text.JSON-import Reactive.Threepenny -import qualified Graphics.UI.Threepenny.Internal.Core as Core-import Graphics.UI.Threepenny.Internal.Core- (getRequestLocation,- 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, defaultConfig, EventData, Session(..))+import Reactive.Threepenny hiding (onChange)+import qualified Reactive.Threepenny as Reactive +import qualified Graphics.UI.Threepenny.Internal.Driver as Core+import Graphics.UI.Threepenny.Internal.Driver+ ( getRequestLocation+ , callDeferredFunction, atomic, )+import Graphics.UI.Threepenny.Internal.FFI+import Graphics.UI.Threepenny.Internal.Types as Core+ ( Window, Config, defaultConfig, Events, EventData+ , ElementData(..), withElementData,)+++import Graphics.UI.Threepenny.Internal.Types as Core+ (unprotectedGetElementId, withElementData, ElementData(..))+ {----------------------------------------------------------------------------- Server ------------------------------------------------------------------------------}@@ -93,272 +111,265 @@ -- | Start server for GUI sessions. startGUI :: Config -- ^ Server configuration.- -> (Window -> IO ()) -- ^ Action to run whenever a client browser connects.+ -> (Window -> UI ()) -- ^ Action to run whenever a client browser connects. -> IO ()-startGUI config handler = Core.serve config handler+startGUI config handler = Core.serve config (\w -> runUI w $ handler w) -- | Make a local file available as a relative URI. loadFile- :: Window -- ^ Browser window- -> String -- ^ MIME type+ :: String -- ^ MIME type -> FilePath -- ^ Local path to the file- -> IO String -- ^ Generated URI-loadFile w mime path = Core.loadFile w (fromString mime) path+ -> UI String -- ^ Generated URI+loadFile mime path = askWindow >>= \w -> liftIO $+ Core.loadFile w (fromString mime) path -- | Make a local directory available as a relative URI.-loadDirectory :: Window -> FilePath -> IO String-loadDirectory = Core.loadDirectory+loadDirectory :: FilePath -> UI String+loadDirectory path = askWindow >>= \w -> liftIO $+ Core.loadDirectory w path + {-----------------------------------------------------------------------------+ UI monad+------------------------------------------------------------------------------}+{- |++User interface elements are created and manipulated in the 'UI' monad.++This monad is essentially just a thin wrapper around the familiar 'IO' monad.+Use the 'liftIO' function to access 'IO' operations like reading+and writing from files.++There are several subtle reasons why Threepenny+uses a custom 'UI' monad instead of the standard 'IO' monad:++* More convenience when calling JavaScript.+The monad keeps track of a browser 'Window' context+in which JavaScript function calls are executed.++* Recursion for functional reactive programming.++-}+newtype UI a = UI { unUI :: Monad.RWST Window [IO ()] () IO a }+ deriving (Typeable)++instance Functor UI where+ fmap f = UI . fmap f . unUI++instance Monad UI where+ return = UI . return+ m >>= k = UI $ unUI m >>= unUI . k++instance MonadIO UI where+ liftIO = UI . liftIO++instance MonadFix UI where+ mfix f = UI $ mfix (unUI . f) ++-- | Execute an 'UI' action in a particular browser window.+-- Also runs all scheduled 'IO' action.+runUI :: Window -> UI a -> IO a+runUI window m = do+ (a, _, actions) <- Monad.runRWST (unUI m) window ()+ sequence_ actions+ return a++-- | Retrieve current 'Window' context in the 'UI' monad.+askWindow :: UI Window+askWindow = UI Monad.ask++-- | Schedule an 'IO' action to be run later.+liftIOLater :: IO () -> UI ()+liftIOLater x = UI $ Monad.tell [x]++{----------------------------------------------------------------------------- Browser window ------------------------------------------------------------------------------} -- | Title of the client window. title :: WriteAttr Window String-title = mkWriteAttr Core.setTitle+title = mkWriteAttr $ \s _ ->+ runFunction $ ffi "document.title = %1;" s -- | Cookies on the client. cookies :: ReadAttr Window [(String,String)]-cookies = mkReadAttr Core.getRequestCookies+cookies = mkReadAttr (liftIO . Core.getRequestCookies) {----------------------------------------------------------------------------- Elements ------------------------------------------------------------------------------}-type Value = String---- | Reference to an element in the DOM of the client window.-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---- Turn a live reference into an 'Element'.--- 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@(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- e <- takeMVar me- case e of- Alive e -> do -- update immediately- f e- putMVar me $ Alive e- Limbo value create -> -- update on creation- putMVar me $ Limbo value $ \w -> create w >>= \e -> f e >> return e---- Given a browser window, make sure that the element exists there.--- 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 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+data Element = Element { eEvents :: Core.Events, toElement :: Core.Element }+ deriving (Typeable) +fromElement :: Core.Element -> IO Element+fromElement e = do+ events <- Core.withElementData e $ \_ x -> return $ elEvents x + return $ Element events e --- Append a child element to a parent element. Non-blocking.-appendTo- :: Element -- ^ Parent.- -> Element -- ^ Child.- -> IO ()-appendTo parent child = do- flip updateElement parent $ \x -> do- y <- manifestElement (Core.getWindow x) child- Core.appendElementTo x y+instance ToJS Element where+ render = render . toElement -- | Make a new DOM element. mkElement :: String -- ^ Tag name- -> IO Element-mkElement tag = do- -- create element in Limbo- ref <- newMVar (Limbo "" $ \w -> Core.newElement w tag)+ -> UI Element+mkElement tag = mdo -- 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+ let initializeEvent (name,_,handler) = Core.bind name el handler+ events <- liftIO $ newEventsNamed initializeEvent+ + window <- askWindow+ el <- liftIO $ Core.newElement window tag events+ return $ Element events el -- | 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,--- you have to append it to a parent, for instance with the `(#+)` operator.------ 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- e1 <- readMVar ref- return $ case e1 of- Alive e -> Just $ Core.getWindow e- Limbo _ _ -> Nothing+getWindow :: Element -> IO Window+getWindow e = Core.getWindow (toElement e) -- | Delete the given element.-delete :: Element -> IO ()-delete = updateElement (Core.delete)+delete :: Element -> UI ()+delete = liftIO . Core.delete . toElement -- | Append DOM elements as children to a given element.-(#+) :: IO Element -> [IO Element] -> IO Element+(#+) :: UI Element -> [UI Element] -> UI Element (#+) mx mys = do x <- mx ys <- sequence mys- mapM_ (appendTo x) ys+ liftIO $ mapM_ (Core.appendElementTo (toElement x) . toElement) ys return x -- | Child elements of a given element. children :: WriteAttr Element [Element] children = mkWriteAttr set where- set xs x = do- updateElement Core.emptyEl x- mapM_ (appendTo x) xs+ set xs x = liftIO $ do+ Core.emptyEl $ toElement x+ mapM_ (Core.appendElementTo (toElement x) . toElement) xs -- | Child elements of a given element as a HTML string. html :: WriteAttr Element String-html = mkWriteAttr (updateElement . Core.setHtml)+html = mkWriteAttr $ \s el ->+ runFunction $ ffi "$(%1).html(%2)" el s -- | HTML attributes of an element. attr :: String -> WriteAttr Element String-attr name = mkWriteAttr (updateElement . Core.setAttr name)+attr name = mkWriteAttr $ \s el ->+ runFunction $ ffi "$(%1).attr(%2,%3)" el name s -- | Set CSS style of an Element style :: WriteAttr Element [(String,String)]-style = mkWriteAttr (updateElement . Core.setStyle)+style = mkWriteAttr $ \xs el -> forM_ xs $ \(name,val) -> + runFunction $ ffi "%1.style[%2] = %3" el name val -- | Value attribute of an element. -- Particularly relevant for control widgets like 'input'. value :: Attr Element String value = mkReadWriteAttr get set where- 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- - setValue v (Limbo _ f) = return $ Limbo v f- setValue v (Alive e ) = Core.setAttr "value" v e >> return (Alive e)- - updateMVar f ref = do- x <- takeMVar ref- y <- f x- putMVar ref y+ get el = callFunction $ ffi "$(%1).val()" el+ set v el = runFunction $ ffi "$(%1).val(%2)" el v -- | Get values from inputs. Blocks. This is faster than many 'getValue' invocations. getValuesList :: [Element] -- ^ A list of elements to get the values of.- -> IO [String] -- ^ The list of plain text values.+ -> UI [String] -- ^ The list of plain text values. getValuesList = mapM (get value) -- TODO: improve this to use Core.getValuesList -- | Text content of an element. text :: WriteAttr Element String-text = mkWriteAttr (updateElement . Core.setText)+text = mkWriteAttr $ \s el ->+ runFunction $ ffi "$(%1).text(%2)" el s -- | Make a @span@ element with a given text content.-string :: String -> IO Element+string :: String -> UI Element string s = mkElement "span" # set text s -- | Get the head of the page.-getHead :: Window -> IO Element-getHead = fromAlive <=< Core.getHead+getHead :: Window -> UI Element+getHead w = liftIO $ fromElement =<< Core.getHead w -- | Get the body of the page.-getBody :: Window -> IO Element-getBody = fromAlive <=< Core.getBody---- | Get an element by its tag name. Blocks.-getElementByTagName- :: Window -- ^ Browser window- -> String -- ^ The tag name.- -> IO (Maybe Element) -- ^ An element (if any) with that tag name.-getElementByTagName window = liftM listToMaybe . getElementsByTagName window+getBody :: Window -> UI Element+getBody w = liftIO $ fromElement =<< Core.getBody w -- | Get all elements of the given tag name. Blocks. getElementsByTagName :: Window -- ^ Browser window -> String -- ^ The tag name.- -> IO [Element] -- ^ All elements with that tag name.-getElementsByTagName window name =- mapM fromAlive =<< Core.getElementsByTagName window name+ -> UI [Element] -- ^ All elements with that tag name.+getElementsByTagName window name = liftIO $+ mapM fromElement =<< Core.getElementsByTagName window name -- | Get an element by a particular ID. Blocks. getElementById :: Window -- ^ Browser window -> String -- ^ The ID string.- -> IO (Maybe Element) -- ^ Element (if any) with given ID.-getElementById window id = listToMaybe `fmap` getElementsById window [id]---- | Get a list of elements by particular IDs. Blocks.-getElementsById- :: Window -- ^ Browser window- -> [String] -- ^ The ID string.- -> IO [Element] -- ^ Elements with given ID.-getElementsById window name =- mapM fromAlive =<< Core.getElementsById window name+ -> UI (Maybe Element) -- ^ Element (if any) with given ID.+getElementById window id = liftIO $+ fmap listToMaybe $ mapM fromElement =<< Core.getElementsById window [id] -- | 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+ -> UI [Element] -- ^ Elements with given class.+getElementsByClassName window cls = liftIO $+ mapM fromElement =<< Core.getElementsByClassName window cls + {-----------------------------------------------------------------------------+ FFI+------------------------------------------------------------------------------}+-- | Run the given JavaScript function and carry on. Doesn't block.+--+-- The client window uses JavaScript's @eval()@ function to run the code.+runFunction :: JSFunction () -> UI ()+runFunction fun = do+ window <- askWindow+ liftIO $ Core.runFunction window fun ++-- | Run the given JavaScript function and wait for results. Blocks.+--+-- The client window uses JavaScript's @eval()@ function to run the code.+callFunction :: JSFunction a -> UI a+callFunction fun = do+ window <- askWindow+ liftIO $ Core.callFunction window fun+++{----------------------------------------------------------------------------- Oddball ------------------------------------------------------------------------------}+-- | Print a message on the client console if the client has debugging enabled.+debug :: String -> UI ()+debug s = askWindow >>= \w -> liftIO $ Core.debug w s+ -- | Invoke the JavaScript expression @audioElement.play();@.-audioPlay = updateElement $ \el -> Core.runFunction (Core.getWindow el) $- ffi "%1.play()" el+audioPlay :: Element -> UI ()+audioPlay el = runFunction $ ffi "%1.play()" el -- | Invoke the JavaScript expression @audioElement.stop();@.-audioStop = updateElement $ \el -> Core.runFunction (Core.getWindow el) $- ffi "prim_audio_stop(%1)" el+audioStop :: Element -> UI ()+audioStop el = runFunction $ 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- me <- readMVar ref- case me of- Limbo _ _ -> error "'checked' attribute: element must be in a browser window"- Alive e -> from <$> Core.getProp name e+ set v el = runFunction $ ffi "$(%1).prop(%2,%3)" el name (to v)+ get el = fmap from $ callFunction $ ffi "$(%1).prop(%2)" el name {----------------------------------------------------------------------------- Layout ------------------------------------------------------------------------------} -- | Align given elements in a row. Special case of 'grid'.-row :: [IO Element] -> IO Element+row :: [UI Element] -> UI Element row xs = grid [xs] -- | Align given elements in a column. Special case of 'grid'.-column :: [IO Element] -> IO Element+column :: [UI Element] -> UI Element column = grid . map (:[]) -- | Align given elements in a rectangular grid.@@ -380,7 +391,7 @@ -- You can customatize the actual layout by assigning an @id@ to the element -- and changing the @.table@, @.table-row@ and @table-column@ -- classes in a custom CSS file.-grid :: [[IO Element]] -> IO Element+grid :: [[UI Element]] -> UI Element grid mrows = do rows0 <- mapM (sequence) mrows @@ -407,21 +418,6 @@ -> Event EventData domEvent name (Element events _) = events name -{- - ref <- newIORef $ return ()- let- -- register handler and remember unregister function- register' = flip updateElement element $ \e -> do- unregister <- register (Core.bind name e) handler- writeIORef ref unregister- - -- update element to unregister the event handler- unregister' = flip updateElement element $ \_ -> do- join $ readIORef ref- - register'- return unregister'--} -- | Event that occurs whenever the client has disconnected, -- be it by closing the browser window or by exception.@@ -436,10 +432,26 @@ -- Example usage. -- -- > on click element $ \_ -> ...-on :: (element -> Event a) -> element -> (a -> IO void) -> IO ()-on f x h = register (f x) (void . h) >> return ()+on :: (element -> Event a) -> element -> (a -> UI void) -> UI ()+on f x = onEvent (f x) +-- | Register an 'UI' action to be executed whenever the 'Event' happens.+-- +-- FIXME: Should be unified with 'on'?+onEvent :: Event a -> (a -> UI void) -> UI ()+onEvent e h = do+ window <- askWindow+ liftIO $ register e (void . runUI window . h)+ return () +-- | Execute a 'UI' action whenever a 'Behavior' changes.+-- Use sparingly, it is recommended that you use 'sink' instead.+onChanges :: Behavior a -> (a -> UI void) -> UI ()+onChanges b f = do+ window <- askWindow+ liftIO $ Reactive.onChange b (void . runUI window . f)++ {----------------------------------------------------------------------------- Attributes ------------------------------------------------------------------------------}@@ -460,20 +472,9 @@ (#) = flip ($) -- | Convenient combinator for setting the CSS class on element creation.-(#.) :: IO Element -> String -> IO Element+(#.) :: UI Element -> String -> UI Element (#.) mx s = mx # set (attr "class") s ---- | Convience synonym for 'return' to make elements work well with 'set'.------ Example usage.------ > e <- mkElement "button"--- > element e # set text "Ok"-element :: Element -> IO Element-element = return-- -- | Attributes can be 'set' and 'get'. type Attr x a = ReadWriteAttr x a a @@ -485,44 +486,71 @@ -- | Generalized attribute with different types for getting and setting. data ReadWriteAttr x i o = ReadWriteAttr- { get' :: x -> IO o- , set' :: i -> x -> IO ()+ { get' :: x -> UI o+ , set' :: i -> x -> UI () } --- | Set value of an attribute in the 'IO' monad.+-- | Set value of an attribute in the 'UI' monad. -- 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 :: ReadWriteAttr x i o -> i -> UI x -> UI x+set attr i mx = do { x <- mx; 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 :: ReadWriteAttr x i o -> Behavior i -> UI x -> UI x sink attr bi mx = do x <- mx- do+ window <- askWindow+ liftIOLater $ do i <- currentValue bi- set' attr i x- onChange bi $ \i -> set' attr i x + runUI window $ set' attr i x+ Reactive.onChange bi $ \i -> runUI window $ set' attr i x return x -- | Get attribute value.-get :: ReadWriteAttr x i o -> x -> IO o-get = get'+get :: ReadWriteAttr x i o -> x -> UI o+get attr = get' attr -- | Build an attribute from a getter and a setter. mkReadWriteAttr- :: (x -> IO o) -- ^ Getter.- -> (i -> x -> IO ()) -- ^ Setter.+ :: (x -> UI o) -- ^ Getter.+ -> (i -> x -> UI ()) -- ^ Setter. -> ReadWriteAttr x i o mkReadWriteAttr get set = ReadWriteAttr { get' = get, set' = set } -- | Build attribute from a getter.-mkReadAttr :: (x -> IO o) -> ReadAttr x o+mkReadAttr :: (x -> UI o) -> ReadAttr x o mkReadAttr get = mkReadWriteAttr get (\_ _ -> return ()) -- | Build attribute from a setter.-mkWriteAttr :: (i -> x -> IO ()) -> WriteAttr x i+mkWriteAttr :: (i -> x -> UI ()) -> WriteAttr x i mkWriteAttr set = mkReadWriteAttr (\_ -> return ()) set+++{-----------------------------------------------------------------------------+ Widget class+------------------------------------------------------------------------------}+-- | Widgets are data types that have a visual representation.+class Widget w where+ getElement :: w -> Element++instance Widget Element where+ getElement = id+++-- | Convience synonym for 'return' to make elements work well with 'set'.+-- Also works on 'Widget's.+--+-- Example usage.+--+-- > e <- mkElement "button"+-- > element e # set text "Ok"+element :: MonadIO m => Widget w => w -> m Element+element = return . getElement++-- | Convience synonym for 'return' to make widgets work well with 'set'.+widget :: Widget w => w -> UI w+widget = return
src/Graphics/UI/Threepenny/Elements.hs view
@@ -38,7 +38,7 @@ addStyleSheet :: Window -> FilePath- -> IO ()+ -> UI () addStyleSheet w filename = void $ do el <- mkElement "link" # set (attr "rel" ) "stylesheet"@@ -47,7 +47,7 @@ getHead w #+ [element el] -- | Make a new @div@ element, synonym for 'div'.-new :: IO Element+new :: UI Element new = div {-----------------------------------------------------------------------------
src/Graphics/UI/Threepenny/Events.hs view
@@ -6,7 +6,8 @@ valueChange, selectionChange, checkedChange, -- * Standard DOM events- click, mousemove, hover, blur, leave,+ click, mousemove, mousedown, mouseup, hover, leave,+ focus, blur, KeyCode, keyup, keydown, ) where @@ -20,16 +21,18 @@ ------------------------------------------------------------------------------} -- | 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)+valueChange el = unsafeMapUI el (const $ get value el) (domEvent "keydown" el) +unsafeMapUI el f = unsafeMapIO (\a -> getWindow el >>= \w -> runUI w (f a))+ -- | 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)+selectionChange el = unsafeMapUI el (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)+checkedChange el = unsafeMapUI el (const $ get checked el) (click el) {----------------------------------------------------------------------------- DOM Events@@ -38,25 +41,41 @@ click :: Element -> Event () click = silence . domEvent "click" --- | Mouse hovering over an element.+-- | Mouse enters an element. hover :: Element -> Event () hover = silence . domEvent "mouseenter" -- | Event that periodically occurs while the mouse is moving over an element. -- -- The event value represents the mouse coordinates--- relative to the upper left corner of the entire page.+-- relative to the upper left corner of the element. -- -- Note: The @<body>@ element responds to mouse move events, -- but only in the area occupied by actual content, -- not the whole browser window. mousemove :: Element -> Event (Int,Int)-mousemove = fmap readPair . domEvent "mousemove"- where readPair (EventData (Just x:Just y:_)) = (read x, read y)+mousemove = fmap readCoordinates . domEvent "mousemove" +readCoordinates :: EventData -> (Int,Int)+readCoordinates (EventData (Just x:Just y:_)) = (read x, read y)++-- | Mouse down event.+-- The mouse coordinates are relative to the element. +mousedown :: Element -> Event (Int,Int)+mousedown = fmap readCoordinates . domEvent "mousedown"++-- | Mouse up event.+-- The mouse coordinates are relative to the element. +mouseup :: Element -> Event (Int,Int)+mouseup = fmap readCoordinates . domEvent "mouseup"+ -- | Mouse leaving an element. leave :: Element -> Event () leave = silence . domEvent "mouseleave"++-- | Element receives focus.+focus :: Element -> Event ()+focus = silence . domEvent "focus" -- | Element loses focus. blur :: Element -> Event ()
− src/Graphics/UI/Threepenny/Internal/Core.hs
@@ -1,732 +0,0 @@-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE OverloadedStrings, PackageImports #-}-{-# OPTIONS -fno-warn-name-shadowing #-}--module Graphics.UI.Threepenny.Internal.Core- (- -- * Synopsis- -- | The main internal functionality.- - -- * Server running- serve- ,loadFile- ,loadDirectory- - -- * Event handling- -- $eventhandling- ,bind- ,disconnect- ,module Reactive.Threepenny- - -- * Setting attributes- -- $settingattributes- ,setStyle- ,setAttr- ,setProp- ,setText- ,setHtml- ,setTitle- ,emptyEl- ,delete- - -- * Manipulating tree structure- -- $treestructure- ,newElement- ,appendElementTo- - -- * Querying- -- $querying- ,getHead- ,getBody- ,getElementsByTagName- ,getElementsById- ,getElementsByClassName- ,getWindow- ,getProp- ,getValue- ,getValuesList- ,readValue- ,readValuesList- ,getRequestCookies- ,getRequestLocation- - -- * Utilities- ,debug- ,clear- ,callDeferredFunction- ,atomic-- -- * JavaScript FFI- ,ToJS, FFI, ffi, JSFunction- ,runFunction, callFunction- - -- * Types- ,Window- ,Element- ,Config(..)- ,EventData(..)- ) where----import Graphics.UI.Threepenny.Internal.Types as Threepenny-import Graphics.UI.Threepenny.Internal.Resources--import Control.Applicative-import Control.Concurrent-import Control.Concurrent.Chan.Extra-import Control.Concurrent.Delay-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)-import qualified Data.Map as M-import Data.Maybe-import Data.Text (Text,pack,unpack)-import qualified Data.Text as Text-import Data.Text.Encoding-import Data.Time-import Network.URI-import qualified Network.WebSockets as WS-import qualified Network.WebSockets.Snap as WS-import qualified Data.Attoparsec.Enumerator as Atto-import Prelude hiding (init)-import Safe-import Snap.Core-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 and and session management-------------------------------------------------------------------------------}-newServerState :: IO ServerState-newServerState = ServerState - <$> newMVar M.empty- <*> newMVar (0,M.empty)- <*> newMVar (0,M.empty)---- | Run a TP server with Snap on the specified port and the given--- worker action.-serve :: Config -> (Session -> IO ()) -> IO ()-serve Config{..} worker = do- 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 ()-custodian seconds sessions = forever $ do- delaySeconds seconds- modifyMVar_ sessions $ \sessions -> do- killed <- fmap catMaybes $ forM (M.assocs sessions) $ \(key,Session{..}) -> do- state <- readMVar sConnectedState- case state of- Connected -> return Nothing- Disconnected time -> do- now <- getCurrentTime- let dcSeconds = diffUTCTime now time- -- session is disconnected for more than seconds- if (dcSeconds > fromIntegral seconds)- then do killThread sThreadId- return (Just key)- else return Nothing- - -- remove killed sessions from the map- return (M.filterWithKey (\k _ -> not (k `elem` killed)) sessions)---- Run a snap action with the given session.-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 -> 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) <- 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---- FIXME: Serving large files fails with the exception--- System.SendFile.Darwin: invalid argument (Socket is not connected)---newAssociation :: MVar Filepaths -> (FilePath, MimeType) -> IO String-newAssociation rDict (path,mimetype) = do- (old, dict) <- takeMVar rDict- let new = old + 1; key = show new ++ takeFileName path- putMVar rDict $ (new, M.insert (fromString key) (path,mimetype) dict)- return key---- | Begin to serve a local file under an URI.-loadFile :: Session -> MimeType -> FilePath -> IO String-loadFile Session{..} mimetype path = do- key <- newAssociation (sFiles sServerState) (path,mimetype)- return $ "/file/" ++ key---- | Begin to serve a local directory under an URI.-loadDirectory :: Session -> FilePath -> IO String-loadDirectory Session{..} path = do- key <- newAssociation (sDirs sServerState) (path,"")- return $ "/dir/" ++ key---{------------------------------------------------------------------------------ Event handling-------------------------------------------------------------------------------}-{- $eventhandling-- To bind events to elements, use the 'bind' function.-- To handle DOM events, use the 'handleEvent' function, or the- 'handleEvents' function which will block forever.-- See the rest of this section for some helpful functions that do- common binding, such as clicks, hovers, etc.--}---- | Handle events signalled from the client.-handleEvents :: Window -> IO ()-handleEvents window@(Session{..}) = do- signal <- getSignal window- case signal of- Threepenny.Event (elid,eventType,params) -> do- 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---- | 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.- -> Handler EventData -- ^ The event handler to bind.- -> IO ()-bind eventType (Element el@(ElementId elid) session) handler = do- let key = (elid, eventType)- -- register with client if it has never been registered on the server- handlers <- readMVar $ sEventHandlers session- when (not $ key `M.member` handlers) $- run session $ Bind eventType el (Closure key)- -- register with server- addEventHandler session (key, handler)---- | Register event handler that occurs when the client has disconnected.-disconnect :: Window -> Event ()-disconnect = 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 eventType elid thunk = do- let key = (elid, eventType)- addEventHandler window (key, \(EventData xs) -> thunk xs)- return (Closure key)--{------------------------------------------------------------------------------ Setting attributes-------------------------------------------------------------------------------}-{- $settingattributes- - Text, HTML and attributes of DOM nodes can be set using the- functions in this section. --}---- | Set the style of the given element.-setStyle :: [(String, String)] -- ^ Pairs of CSS (property,value).- -> Element -- ^ The element to update.- -> IO ()-setStyle props e@(Element el session) = run session $ SetStyle el props---- | Set the attribute of the given element.-setAttr :: String -- ^ The attribute name.- -> String -- ^ The attribute value.- -> Element -- ^ The element to update.- -> IO ()-setAttr key value e@(Element el session) = run session $ SetAttr el key value---- | Set the property of the given element.-setProp :: String -- ^ The property name.- -> JSValue -- ^ The property value.- -> Element -- ^ The element to update.- -> IO ()-setProp key value e@(Element el session) =- runFunction session $ ffi "$(%1).prop(%2,%3);" el key value---- | Set the text of the given element.-setText :: String -- ^ The plain text.- -> Element -- ^ The element to update.- -> IO ()-setText props e@(Element el session) = run session $ SetText el props---- | Set the HTML of the given element.-setHtml :: String -- ^ The HTML.- -> Element -- ^ The element to update.- -> IO ()-setHtml props e@(Element el session) = run session $ SetHtml el props---- | Set the title of the document.-setTitle- :: String -- ^ The title.- -> Window -- ^ The document window- -> IO ()-setTitle title session = run session $ SetTitle title---- | Empty the given element.-emptyEl :: Element -> IO ()-emptyEl e@(Element el session) = run session $ EmptyEl el---- | Delete the given element.-delete :: Element -> IO ()-delete e@(Element el session) = run session $ Delete el---{------------------------------------------------------------------------------ Manipulating tree structure-------------------------------------------------------------------------------}--- $treestructure------ Functions for creating, deleting, moving, appending, prepending, DOM nodes.---- | Create a new element of the given tag name.-newElement :: Window -- ^ Browser window in which context to create the element- -> String -- ^ The tag name.- -> IO Element -- ^ A tag reference. Non-blocking.-newElement session@(Session{..}) tagName = do- elid <- modifyMVar sElementIds $ \elids ->- return (tail elids,"*" ++ show (head elids) ++ ":" ++ tagName)- return (Element (ElementId elid) session)---- | Append a child element to a parent element. Non-blocking.-appendElementTo- :: Element -- ^ Parent.- -> Element -- ^ Child.- -> IO () -appendElementTo (Element parent session) e@(Element child _) =- -- TODO: Right now, parent and child need to be from the same session/browser window- -- Implement transfer of elements across browser windows- run session $ Append parent child--{------------------------------------------------------------------------------ Querying the DOM-------------------------------------------------------------------------------}--- $querying--- --- The DOM can be searched for elements of a given name, and nodes can--- be inspected for their values.---- | Get all elements of the given tag name. Blocks.-getElementsByTagName- :: Window -- ^ Browser window- -> String -- ^ The tag name.- -> IO [Element] -- ^ All elements with that tag name.-getElementsByTagName window tagName =- call window (GetElementsByTagName tagName) $ \signal ->- case signal of- Elements els -> return $ Just $ [Element el window | el <- els]- _ -> return Nothing---- | Get a list of elements by particular IDs. Blocks.-getElementsById- :: Window -- ^ Browser window- -> [String] -- ^ The ID string.- -> IO [Element] -- ^ Elements with given ID.-getElementsById window ids =- call window (GetElementsById ids) $ \signal ->- case signal of- 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.- -> IO String -- ^ The plain text value.-getValue e@(Element el window) =- call window (GetValue el) $ \signal ->- case signal of- Value str -> return (Just str)- _ -> return Nothing---- | Get the property of an element. Blocks.-getProp- :: String -- ^ The property name.- -> Element -- ^ The element to get the value of.- -> IO JSValue -- ^ The plain text value.-getProp prop e@(Element el window) =- callFunction window (ffi "$(%1).prop(%2)" el prop)---- | Get 'Window' associated to an 'Element'.-getWindow :: Element -> Window-getWindow (Element _ window) = window---- | Get values from inputs. Blocks. This is faster than many 'getValue' invocations.-getValuesList- :: [Element] -- ^ A list of elements to get the values of.- -> IO [String] -- ^ The list of plain text values.-getValuesList [] = return []-getValuesList es@(Element _ window : _) =- let elids = [elid | Element elid _ <- es] in- call window (GetValues elids) $ \signal ->- case signal of- Values strs -> return $ Just strs- _ -> return Nothing---- | Read a value from an input. Blocks.-readValue- :: Read a- => Element -- ^ The element to read a value from.- -> IO (Maybe a) -- ^ Maybe the read value.-readValue = liftM readMay . getValue---- | Read values from inputs. Blocks. This is faster than many 'readValue' invocations.-readValuesList- :: Read a- => [Element] -- ^ The element to read a value from.- -> IO (Maybe [a]) -- ^ Maybe the read values. All or none.-readValuesList = liftM (sequence . map readMay) . getValuesList---- | Get the head of the page.-getHead :: Window -> IO Element-getHead session = return $ Element (ElementId "head") session---- | Get the body of the page.-getBody :: Window -> IO Element-getBody session = return $ Element (ElementId "body") session---- | Get the request location.-getRequestLocation :: Window -> IO URI-getRequestLocation = return . fst . sStartInfo---- | Get the request cookies.-getRequestCookies :: Window -> IO [(String,String)]-getRequestCookies = return . snd . sStartInfo--{------------------------------------------------------------------------------ Utilities-------------------------------------------------------------------------------}--- | Send a debug message to the client. The behaviour of the client--- is unspecified.-debug- :: Window -- ^ Client window- -> String -- ^ Some plain text to send to the client.- -> IO ()-debug window = run window . Debug---- | Clear the client's DOM.-clear :: Window -> IO ()-clear window = runFunction window $ ffi "$('body').contents().detach()"
+ src/Graphics/UI/Threepenny/Internal/Driver.hs view
@@ -0,0 +1,673 @@+{-# LANGUAGE CPP, PackageImports #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecursiveDo #-}+{-# OPTIONS -fno-warn-name-shadowing #-}++module Graphics.UI.Threepenny.Internal.Driver+ (+ -- * Synopsis+ -- | The main internal functionality.+ + -- * Server running+ serve+ ,loadFile+ ,loadDirectory++ -- * Elements+ ,newElement+ ,appendElementTo+ ,emptyEl+ ,delete+ + -- * Event handling+ -- $eventhandling+ ,bind+ ,disconnect+ ,module Reactive.Threepenny+ + -- * Querying+ -- $querying+ ,getHead+ ,getBody+ ,getElementsByTagName+ ,getElementsById+ ,getElementsByClassName+ ,getWindow+ ,getValuesList+ ,getRequestCookies+ ,getRequestLocation+ + -- * Utilities+ ,debug+ ,callDeferredFunction+ ,atomic++ -- * JavaScript FFI+ ,ToJS, FFI, ffi, JSFunction+ ,runFunction, callFunction+ + -- * Types+ ,Window+ ,Element+ ,Config(..)+ ,EventData(..)+ ) where++++import Control.Applicative+import Control.Concurrent+import Control.Concurrent.Chan.Extra+import Control.Concurrent.Delay+import Control.DeepSeq+import qualified Control.Exception+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)+import qualified Data.Map as M+import Data.Maybe+import Data.Text (Text,pack,unpack)+import qualified Data.Text as Text+import Data.Text.Encoding+import Data.Time+import Network.URI+import qualified Network.WebSockets as WS+import qualified Network.WebSockets.Snap as WS+import qualified Data.Attoparsec.Enumerator as Atto+import Prelude hiding (init)+import Safe+import Snap.Core+import qualified Snap.Http.Server as Snap+import Snap.Util.FileServe+import System.FilePath+import qualified Text.JSON as JSON+import Text.JSON.Generic+++import Graphics.UI.Threepenny.Internal.Types as Threepenny+import Graphics.UI.Threepenny.Internal.Resources+import Graphics.UI.Threepenny.Internal.FFI+import Reactive.Threepenny++import qualified Foreign.Coupon as Foreign+import qualified System.Mem++{-----------------------------------------------------------------------------+ Server and and session management+------------------------------------------------------------------------------}+newServerState :: IO ServerState+newServerState = ServerState + <$> newMVar M.empty+ <*> newMVar (0,M.empty)+ <*> newMVar (0,M.empty)++-- | Run a TP server with Snap on the specified port and the given+-- worker action.+serve :: Config -> (Session -> IO ()) -> IO ()+serve Config{..} worker = do+ 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 ()+custodian seconds sessions = forever $ do+ delaySeconds seconds+ modifyMVar_ sessions $ \sessions -> do+ killed <- fmap catMaybes $ forM (M.assocs sessions) $ \(key,Session{..}) -> do+ state <- readMVar sConnectedState+ case state of+ Connected -> return Nothing+ Disconnected time -> do+ now <- getCurrentTime+ let dcSeconds = diffUTCTime now time+ -- session is disconnected for more than seconds+ if (dcSeconds > fromIntegral seconds)+ then do killThread sThreadId+ return (Just key)+ else return Nothing+ + -- remove killed sessions from the map+ return (M.filterWithKey (\k _ -> not (k `elem` killed)) sessions)++-- Run a snap action with the given session.+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 ()+ sEventQuit <- newEvent+ sPrizeBooth <- Foreign.newPrizeBooth+ let sHeadElement = undefined -- filled in later+ let sBodyElement = undefined+ now <- getCurrentTime+ sConnectedState <- newMVar (Disconnected now)+ sThreadId <- myThreadId+ sClosures <- newMVar [0..]+ let session = Session {..}+ initializeElements 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.PendingConnection -> IO ()+webSocket Session{..} request = void $ do+ connection <- WS.acceptRequest request+ -- websockets are always connected, don't let the custodian kill you.+ modifyMVar_ sConnectedState (const (return Connected))++ -- write data (in another thread)+ sendData <- forkIO . forever $ do+ x <- readChan sInstructions+ -- see note [Instruction strictness]+ WS.sendTextData connection . Text.pack . JSON.encode $ x++ -- read data+ let readData = do+ input <- WS.receiveData connection+ case input of+ "ping" -> WS.sendTextData connection . Text.pack $ "pong"+ "quit" -> E.throw WS.ConnectionClosed+ input -> case JSON.decode . Text.unpack $ input of+ Ok signal -> writeChan sSignals signal+ Error err -> E.throw $ Atto.ParseError [] err+ + forever readData `E.finally`+ (do+ killThread sendData -- kill sending thread when done+ writeChan sSignals $ Quit () -- signal Quit event+ )++{- note [Instruction strictness]++The Instruction may contain components that evaluate to _|_.+An exception will be thrown when we try to send one of those to the browser.+However, the WS.sendSink function is called in a different thread+than where the faulty instruction was constructed.+We want to throw an exception in the latter thread.+Hence, we make sure that the Instruction is fully evaluated (deepseq)+before passing it to the thread that sends it to the web browser.++(Another, probably preferred, solution would be to make the Instruction+data type fully strict by default.)++-}++++{-----------------------------------------------------------------------------+ 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+ -- see note [Instruction strictness]+ Control.Exception.evaluate $ force instruction+ takeMVar sMutex+ writeChan sInstructions 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{..}) instruction =+ writeChan sInstructions $!! instruction -- see note [Instruction strictness]++-- | 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 window fun params thunk = do+ closure <- newClosure window fun $ \(EventData xs) -> thunk xs+ run window $ CallDeferredFunction (closure,fun,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 . toCode++-- | 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 = + call window (CallJSFunction . toCode $ jsfunction) $ \signal ->+ case signal of+ FunctionResult v -> case marshalResult jsfunction window v of+ Ok a -> return $ Just a+ Error _ -> return Nothing+ _ -> return Nothing+++-- | Package a Haskell function such that it can be called from JavaScript.+-- +-- At the moment, we implement this as an event handler that is+-- attached to the @head@ element.+newClosure+ :: Window -- ^ Browser window context+ -> String -- ^ Function name (for debugging).+ -> (EventData -> IO ()) -- ^ Function to call+ -> IO Closure+newClosure window@(Session{..}) fun thunk = do+ cid <- modifyMVar sClosures $ \(x:xs) -> return (xs,x)+ let eventId = fun ++ "-" ++ show cid+ attachClosure sHeadElement eventId thunk+ return $ Closure (unprotectedGetElementId sHeadElement, eventId)+++{-----------------------------------------------------------------------------+ 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 -> 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) <- 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++-- FIXME: Serving large files fails with the exception+-- System.SendFile.Darwin: invalid argument (Socket is not connected)+++newAssociation :: MVar Filepaths -> (FilePath, MimeType) -> IO String+newAssociation rDict (path,mimetype) = do+ (old, dict) <- takeMVar rDict+ let new = old + 1; key = show new ++ takeFileName path+ putMVar rDict $ (new, M.insert (fromString key) (path,mimetype) dict)+ return key++-- | Begin to serve a local file under an URI.+loadFile :: Session -> MimeType -> FilePath -> IO String+loadFile Session{..} mimetype path = do+ key <- newAssociation (sFiles sServerState) (path,mimetype)+ return $ "/file/" ++ key++-- | Begin to serve a local directory under an URI.+loadDirectory :: Session -> FilePath -> IO String+loadDirectory Session{..} path = do+ key <- newAssociation (sDirs sServerState) (path,"")+ return $ "/dir/" ++ key+++{-----------------------------------------------------------------------------+ Elements+ Creation, Management, Finalization+------------------------------------------------------------------------------}+-- | Create a new element of the given tag name.+newElement :: Window -- ^ Browser window in which context to create the element+ -> String -- ^ The tag name.+ -> Events -- ^ Events associated to that element.+ -> IO Element -- ^ A tag reference. Non-blocking.+newElement elSession@(Session{..}) elTagName elEvents = do+ elHandlers <- newMVar M.empty+ el <- Foreign.newItem sPrizeBooth ElementData{..}+ Foreign.addFinalizer el $ delete el+ -- FIXME: Do not try to delete elements from the session when+ -- the session is broken/disconnected already.+ -- A fix should be part of the run function, though.+ return el++-- | Get 'Window' associated to an 'Element'.+getWindow :: Element -> IO Window+getWindow e = withElement e $ \_ window -> return window++-- | Look up several elements in the browser window.+lookupElements :: Session -> [ElementId] -> IO [Element]+lookupElements window = mapM (flip lookupElement window)++-- | Append a child element to a parent element. Non-blocking.+appendElementTo+ :: Element -- ^ Parent.+ -> Element -- ^ Child.+ -> IO ()+appendElementTo eParent eChild =+ -- TODO: Right now, parent and child need to be from the same session/browser window+ -- Implement transfer of elements across browser windows+ withElement eParent $ \parent session ->+ withElement eChild $ \child _ -> do+ Foreign.addReachable eParent eChild+ runFunction session $ ffi "$(%1).append($(%2))" parent child++-- | Get the head of the page.+getHead :: Window -> IO Element+getHead session = return $ sHeadElement session++-- | Get the body of the page.+getBody :: Window -> IO Element+getBody session = return $ sBodyElement session++-- | Empty the given element.+emptyEl :: Element -> IO ()+emptyEl el = withElement el $ \elid window -> do+ Foreign.clearReachable el+ runFunction window $ ffi "$(%1).contents().detach()" elid++-- | Delete the given element.+delete :: Element -> IO ()+delete el = withElement el $ \elid window ->+ run window $ Delete elid+ -- Note: We want a primitive 'Delete' here, because + -- we do not want the implicit conversion from ElementId to element.+++{-----------------------------------------------------------------------------+ Event handling+------------------------------------------------------------------------------}+{- $eventhandling++ To bind events to elements, use the 'bind' function.++ To handle DOM events, use the 'handleEvent' function, or the+ 'handleEvents' function which will block forever.++ See the rest of this section for some helpful functions that do+ common binding, such as clicks, hovers, etc.+-}++-- | Handle events signalled from the client.+handleEvents :: Window -> IO ()+handleEvents window@(Session{..}) = do+ signal <- getSignal window+ case signal of+ Threepenny.Event elid eventId params -> do+ handleEvent1 window (elid,eventId,EventData params)+#ifdef REBUG+ -- debug garbage collection of elements:+ System.Mem.performGC+#endif+ handleEvents window+ Quit () -> do+ snd sEventQuit ()+ -- do not continue handling events+ _ -> do+ handleEvents window++-- | Handle a single event.+handleEvent1 :: Window -> (ElementId, EventId, EventData) -> IO ()+handleEvent1 window (elid,eventId,params) = do+ el <- lookupElement elid window+ withElementData el $ \_ eldata -> do+ handlers <- readMVar $ elHandlers eldata+ case M.lookup eventId handlers of+ Just handler -> handler params+ Nothing -> return ()++-- Get the latest signal sent from the client.+getSignal :: Window -> IO Signal+getSignal (Session{..}) = readChan sSignals++-- | Associate a new closure with an element.+attachClosure :: Element -> EventId -> Handler EventData -> IO () +attachClosure el eventId handler = withElementData el $ \_ eldata ->+ modifyMVar_ (elHandlers eldata) $ return .+ M.insertWith (\h1 h a -> h1 a >> h a) eventId handler++-- | Bind an event handler for a dom event to an 'Element'.+bind+ :: EventId -- ^ The eventType, see any DOM documentation for a list of these.+ -> Element -- ^ The element to bind to.+ -> Handler EventData -- ^ The event handler to bind.+ -> IO ()+bind eventId e handler = withElementData e $ \elid el -> do+ handlers <- readMVar $ elHandlers el+ -- register with client if it has never been registered on the server+ when (not $ eventId `M.member` handlers) $+ run (elSession el) $ Bind eventId elid+ -- register with server+ attachClosure e eventId handler++-- | Register event handler that occurs when the client has disconnected.+disconnect :: Window -> Event ()+disconnect = fst . sEventQuit++-- | Initialize the 'head' and 'body' elements when the session starts.+initializeElements :: Session -> IO Session+initializeElements session@(Session{..}) = do+ sHeadElement <- createElement "head"+ sBodyElement <- createElement "body"+ return $ Session{..}+ where+ newEvents e = newEventsNamed $ \(name,_,handler) -> bind name e handler+ createElement tag = mdo+ x <- newElement session tag =<< newEvents x+ return x++{-----------------------------------------------------------------------------+ Querying the DOM+------------------------------------------------------------------------------}+-- $querying+-- +-- The DOM can be searched for elements of a given name, and nodes can+-- be inspected for their values.++-- | Get all elements of the given tag name. Blocks.+getElementsByTagName :: Window -> String -> IO [Element]+getElementsByTagName window tag = do+ elids <- callFunction window $ ffi "document.getElementsByTagName(%1)" tag+ lookupElements window elids++-- | Get a list of elements by particular IDs. Blocks.+getElementsById :: Window -> [String] -> IO [Element]+getElementsById window ids = do+ elids <- forM ids $ \x ->+ callFunction window $ ffi "[document.getElementById(%1)]" x+ lookupElements window $ concat elids++-- | Get a list of elements by particular class. Blocks.+getElementsByClassName :: Window -> String -> IO [Element]+getElementsByClassName window cls = do+ elids <- callFunction window $ ffi "document.getElementsByClassName(%1)" cls+ lookupElements window elids++-- | Get values from inputs. Blocks. This is faster than many @getValue@ invocations.+getValuesList+ :: [Element] -- ^ A list of elements to get the values of.+ -> IO [String] -- ^ The list of plain text values.+getValuesList [] = return []+getValuesList es@(e0:_) = withElement e0 $ \_ window -> do+ let elids = map unprotectedGetElementId es+ call window (GetValues elids) $ \signal ->+ case signal of+ Values strs -> return $ Just strs+ _ -> return Nothing++-- | Get the request location.+getRequestLocation :: Window -> IO URI+getRequestLocation = return . fst . sStartInfo++-- | Get the request cookies.+getRequestCookies :: Window -> IO [(String,String)]+getRequestCookies = return . snd . sStartInfo++{-----------------------------------------------------------------------------+ Utilities+------------------------------------------------------------------------------}+-- | Send a debug message to the client. The behaviour of the client+-- is unspecified.+debug+ :: Window -- ^ Client window+ -> String -- ^ Some plain text to send to the client.+ -> IO ()+debug window = run window . Debug
+ src/Graphics/UI/Threepenny/Internal/FFI.hs view
@@ -0,0 +1,130 @@+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}+{-# LANGUAGE DeriveDataTypeable #-}+module Graphics.UI.Threepenny.Internal.FFI (+ -- * Synopsis+ -- | Combinators for creating JavaScript code and marhsalling.+ + -- * Documentation+ ffi,+ FFI(..), ToJS(..),+ JSFunction,+ + toCode, marshalResult,+ ) where++import Data.Functor+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as BS+import Text.JSON.Generic++import Graphics.UI.Threepenny.Internal.Types++{-----------------------------------------------------------------------------+ JavaScript Code and Foreign Function Interface+------------------------------------------------------------------------------}+-- | JavaScript code snippet.+newtype JSCode = JSCode { unJSCode :: String }+ deriving (Eq, Ord, Show, Data, Typeable)++-- | Helper class for rendering Haskell values as JavaScript expressions.+class ToJS a where+ render :: a -> JSCode++instance ToJS String where render = JSCode . show+instance ToJS Int where render = JSCode . show+instance ToJS Bool where render b = JSCode $ if b then "false" else "true"+instance ToJS JSValue where render x = JSCode $ showJSValue x ""+instance ToJS ByteString where render = JSCode . show+instance ToJS ElementId where+ render (ElementId x) = apply "elidToElement(%1)" [render x]+instance ToJS Element where render = render . unprotectedGetElementId+++-- | A JavaScript function with a given output type @a@.+data JSFunction a = JSFunction+ { code :: JSCode -- code snippet+ , marshal :: Window -> JSValue -> Result a -- convert to Haskell value+ }++-- | Render function to a textual representation using JavaScript syntax.+toCode :: JSFunction a -> String+toCode = unJSCode . code++-- | Convert function result to a Haskell value.+marshalResult+ :: JSFunction a -- ^ Function that has been executed+ -> Window -- ^ Browser context+ -> JSValue -- ^ JSON representation of the return value + -> Result a -- ^ +marshalResult = marshal++instance Functor JSFunction where+ fmap f = fmapWindow (const f)++fmapWindow :: (Window -> a -> b) -> JSFunction a -> JSFunction b+fmapWindow f (JSFunction c m) = JSFunction c (\w v -> f w <$> m w v)++fromJSCode :: JSCode -> JSFunction ()+fromJSCode c = JSFunction { code = c, marshal = \_ _ -> Ok () }++-- | Helper class for making 'ffi' a variable argument function.+class FFI a where+ fancy :: ([JSCode] -> JSCode) -> a++instance (ToJS a, FFI b) => FFI (a -> b) where+ fancy f a = fancy $ f . (render a:)++instance FFI (JSFunction ()) where fancy f = fromJSCode $ f []+instance FFI (JSFunction String) where fancy = mkResult "%1.toString()"+instance FFI (JSFunction JSValue) where fancy = mkResult "%1"+instance FFI (JSFunction [ElementId]) where fancy = mkResult "elementsToElids(%1)"++-- FIXME: We need access to IO in order to turn a Coupon into an Element.+{- +instance FFI (JSFunction Element) where+ fancy = fmapWindow (\w elid -> Element elid w) . fancy+-}++mkResult :: JSON a => String -> ([JSCode] -> JSCode) -> JSFunction a+mkResult client f = JSFunction+ { code = apply client [f []]+ , marshal = \w -> readJSON+ }++-- | Simple JavaScript FFI with string substitution.+--+-- Inspired by the Fay language. <http://fay-lang.org/>+--+-- > example :: String -> Int -> JSFunction String+-- > example = ffi "$(%1).prop('checked',%2)"+--+-- The 'ffi' function takes a string argument representing the JavaScript+-- code to be executed on the client.+-- Occurrences of the substrings @%1@ to @%9@ will be replaced by+-- subequent arguments.+--+-- Note: Always specify a type signature! The types automate+-- how values are marshalled between Haskell and JavaScript.+-- The class instances for the 'FFI' class show which conversions are supported.+--+ffi :: FFI a => String -> a+ffi macro = fancy (apply macro)++testFFI :: String -> Int -> JSFunction String+testFFI = ffi "$(%1).prop('checked',%2)"++-- | String substitution.+-- Substitute occurences of %1, %2 up to %9 with the argument strings.+-- The types ensure that the % character has no meaning in the generated output.+-- +-- > apply "%1 and %2" [x,y] = x ++ " and " ++ y+apply :: String -> [JSCode] -> JSCode+apply code args = JSCode $ go code+ where+ argument i = unJSCode (args !! i)+ + go [] = []+ go ('%':c:cs) = argument index ++ go cs+ where index = fromEnum c - fromEnum '1'+ go (c:cs) = c : go cs+
src/Graphics/UI/Threepenny/Internal/Include.hs view
@@ -2,13 +2,14 @@ module Graphics.UI.Threepenny.Internal.Include (include) where import Data.Functor+import System.IO import qualified Language.Haskell.TH as TH import Language.Haskell.TH.Quote #ifdef CABAL root = "src/" #else-root = ""+root = "../src/" -- running examples from ghci #endif include = QuasiQuoter@@ -18,4 +19,9 @@ , quoteDec = undefined } where- f s = TH.LitE . TH.StringL <$> TH.runIO (readFile $ root ++ s)+ f s = TH.LitE . TH.StringL <$> TH.runIO (readFileUTF8 $ root ++ s)++readFileUTF8 path = do+ h <- openFile path ReadMode+ hSetEncoding h utf8+ hGetContents h
src/Graphics/UI/Threepenny/Internal/Types.hs view
@@ -1,5 +1,6 @@+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-} module Graphics.UI.Threepenny.Internal.Types where @@ -7,33 +8,43 @@ import Control.Applicative import Control.Concurrent-import qualified Reactive.Threepenny as E-import Data.ByteString (ByteString, hPut)-import Data.Map (Map)-import Data.String (fromString)+import Control.DeepSeq+import qualified Reactive.Threepenny as E+import Data.ByteString.Char8 (ByteString)+import qualified Data.ByteString.Char8 as BS+import Data.Map (Map)+import Data.String (fromString) import Data.Time import Network.URI import Text.JSON.Generic import System.IO (stderr)+import System.IO.Unsafe +import qualified Foreign.Coupon as Foreign+ {------------------------------------------------------------------------------ Public types+ Elements and ElementIds ------------------------------------------------------------------------------}- -- | Reference to an element in the DOM of the client window.-data Element = Element- { elId :: ElementId- , elSession :: Session+type Element = Foreign.Item ElementData+data ElementData = ElementData+ { elTagName :: String -- element is a <tag>..</tag> element+ , elSession :: Session -- associated browser window+ , elHandlers :: MVar Handlers -- event handlers associated with that element+ , elEvents :: Events -- events associated with that element }+newtype ElementId = ElementId BS.ByteString+ deriving (Data,Typeable,Show,Eq,Ord) -instance Show Element where- show = show . elId+instance NFData ElementId where rnf (ElementId x) = rnf x --- | An opaque reference to an element in the DOM.-data ElementId = ElementId String- deriving (Data,Typeable,Show,Eq,Ord)+type EventId = String+type Handlers = Map EventId (E.Handler EventData)+type Events = EventId -> E.Event EventData ++-- Marshalling ElementId instance JSON ElementId where showJSON (ElementId o) = showJSON o readJSON obj = do@@ -41,16 +52,54 @@ ElementId <$> valFromObj "Element" obj --- | A client session. This type is opaque, you don't need to inspect it.+-- | Perform an action on the element.+-- The element is not garbage collected while the action is run.+withElementData :: Element -> (ElementId -> ElementData -> IO a) -> IO a+withElementData e f = Foreign.withItem e $ \coupon el ->+ let elid = ElementId $ case fromString (elTagName el) of+ "" -> coupon+ "head" -> "head"+ "body" -> "body" + tag -> BS.concat ["*",coupon,":",tag]+ in f elid el++-- | Special case of 'withElementData'.+withElement :: Element -> (ElementId -> Session -> IO b) -> IO b+withElement e f = withElementData e $ \elid el -> f elid (elSession el)++-- | Get 'ElementId' without any guarantee that the element is still alive.+unprotectedGetElementId :: Element -> ElementId+unprotectedGetElementId e = unsafePerformIO . withElement e $ \elid _ -> return elid+++-- | Look up an element in the browser window.+lookupElement :: ElementId -> Session -> IO Element+lookupElement (ElementId xs) Session{..} = case xs of+ "head" -> return sHeadElement+ "body" -> return sBodyElement+ xs -> maybe (error msg) id <$> Foreign.lookup (coupon xs) sPrizeBooth+ where+ coupon xs = if BS.head xs == '*'+ then BS.takeWhile (/= ':') . BS.tail $ xs+ else xs++ msg = "Graphics.UI.Threepenny: Fatal error: ElementId " ++ show xs+ ++ "was garbage collected on the server, but is still present in the browser."+++{-----------------------------------------------------------------------------+ Server+------------------------------------------------------------------------------}+-- | A client session. data Session = Session { sSignals :: Chan Signal , sInstructions :: Chan Instruction , sMutex :: MVar ()- , sEventHandlers :: MVar (Map EventKey (E.Handler EventData))- , sElementEvents :: MVar (Map ElementId ElementEvents) , sEventQuit :: (E.Event (), E.Handler ()) , sClosures :: MVar [Integer]- , sElementIds :: MVar [Integer]+ , sPrizeBooth :: Foreign.PrizeBooth ElementData+ , sHeadElement :: Element+ , sBodyElement :: Element , sToken :: Integer , sConnectedState :: MVar ConnectedState , sThreadId :: ThreadId@@ -62,19 +111,12 @@ 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 } ---- | The client browser window.-type Window = Session- data ConnectedState = Disconnected UTCTime -- ^ The time that the poll disconnected, or -- the first initial connection time.@@ -82,6 +124,20 @@ -- since when. deriving (Show) ++-- | An opaque reference to a closure that the event manager uses to+-- trigger events signalled by the client.+data Closure = Closure (ElementId,EventId)+ deriving (Typeable,Data,Show)++instance NFData Closure where rnf (Closure x) = rnf x++{-----------------------------------------------------------------------------+ Public types+------------------------------------------------------------------------------}+-- | The client browser window.+type Window = Session+ -- | Data from an event. At the moment it is empty. data EventData = EventData [Maybe String] @@ -101,34 +157,22 @@ { tpPort = 10000 , tpCustomHTML = Nothing , tpStatic = Nothing- , tpLog = \s -> hPut stderr s >> hPut stderr (fromString "\n")+ , tpLog = \s -> BS.hPut stderr s >> BS.hPut stderr "\n" } {----------------------------------------------------------------------------- Communication between client and server ------------------------------------------------------------------------------}- -- | An instruction that is sent to the client as JSON. data Instruction = Debug String | SetToken Integer- | GetElementsByClassName String- | GetElementsById [String]- | GetElementsByTagName String- | SetStyle ElementId [(String,String)]- | SetAttr ElementId String String- | Append ElementId ElementId- | SetText ElementId String- | SetHtml ElementId String- | Bind String ElementId Closure- | GetValue ElementId+ | Bind EventId ElementId | GetValues [ElementId]- | SetTitle String | RunJSFunction String | CallJSFunction String | CallDeferredFunction (Closure,String,[String])- | EmptyEl ElementId | Delete ElementId deriving (Typeable,Data,Show) @@ -136,12 +180,20 @@ readJSON _ = error "JSON.Instruction.readJSON: No method implemented." showJSON x = toJSON x +instance NFData Instruction where+ rnf (Debug x ) = rnf x+ rnf (SetToken x ) = rnf x+ rnf (Bind x y) = rnf x `seq` rnf y+ rnf (GetValues xs) = rnf xs+ rnf (RunJSFunction x) = rnf x+ rnf (CallJSFunction x) = rnf x+ rnf (CallDeferredFunction x) = rnf x+ rnf (Delete x) = rnf x+ -- | A signal (mostly events) that are sent from the client to the server. data Signal = Quit ()- | Elements [ElementId]- | Event (String,String,[Maybe String])- | Value String+ | Event ElementId EventId [Maybe String] | Values [String] | FunctionCallValues [Maybe String] | FunctionResult JSValue@@ -152,119 +204,21 @@ readJSON obj = do obj <- readJSON 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+ e <- valFromObj "Event" obj+ elid <- valFromObj "Element" e+ eventId <- valFromObj "EventId" e+ arguments <- valFromObj "Params" e+ args <- mapM nullable arguments+ return $ Event elid eventId args values = Values <$> valFromObj "Values" obj fcallvalues = do FunctionCallValues <$> (valFromObj "FunctionCallValues" obj >>= mapM nullable) fresult = FunctionResult <$> valFromObj "FunctionResult" obj- quit <|> elements <|> event <|> value <|> values <|> fcallvalues <|> fresult+ quit <|> event <|> values <|> fcallvalues <|> fresult -- | Read a JSValue that may be null. nullable :: JSON a => JSValue -> Result (Maybe a) nullable JSNull = return Nothing nullable v = Just <$> readJSON v---- | An opaque reference to a closure that the event manager uses to--- trigger events signalled by the client.-data Closure = Closure EventKey- deriving (Typeable,Data,Show)--{------------------------------------------------------------------------------ JavaScript Code and Foreign Function Interface-------------------------------------------------------------------------------}--- | JavaScript code snippet.-newtype JSCode = JSCode { unJSCode :: String }- deriving (Eq, Ord, Show, Data, Typeable)---- | Class for rendering Haskell types as JavaScript code.-class ToJS a where- render :: a -> JSCode--instance ToJS String where render = JSCode . show-instance ToJS Int where render = JSCode . show-instance ToJS Bool where render b = JSCode $ if b then "false" else "true"-instance ToJS JSValue where render x = JSCode $ showJSValue x ""-instance ToJS ElementId where- render (ElementId x) = apply "elidToElement(%1)" [render x]-instance ToJS Element where render (Element e _) = render e----- | Representation of a JavaScript expression--- with a girven output type.-data JSFunction a = JSFunction- { code :: JSCode -- code snippet- , marshal :: Window -> JSValue -> Result a -- convert to Haskell value- }--instance Functor JSFunction where- fmap f = fmapWindow (const f)--fmapWindow :: (Window -> a -> b) -> JSFunction a -> JSFunction b-fmapWindow f (JSFunction c m) = JSFunction c (\w v -> f w <$> m w v)--fromJSCode :: JSCode -> JSFunction ()-fromJSCode c = JSFunction { code = c, marshal = \_ _ -> Ok () }---- | Helper class for making a simple JavaScript FFI-class FFI a where- fancy :: ([JSCode] -> JSCode) -> a--instance (ToJS a, FFI b) => FFI (a -> b) where- fancy f a = fancy $ f . (render a:)--instance FFI (JSFunction ()) where fancy f = fromJSCode $ f []-instance FFI (JSFunction String) where fancy = mkResult "%1.toString()"-instance FFI (JSFunction JSValue) where fancy = mkResult "%1"-instance FFI (JSFunction ElementId) where- fancy = mkResult "{ Element: elementToElid(%1) }"-instance FFI (JSFunction Element) where- fancy = fmapWindow (\w elid -> Element elid w) . fancy--mkResult :: JSON a => String -> ([JSCode] -> JSCode) -> JSFunction a-mkResult client f = JSFunction- { code = apply client [f []]- , marshal = \w -> readJSON- }---- | Simple JavaScript FFI with string substitution.------ Inspired by the Fay language. <http://fay-lang.org/>------ > example :: String -> Int -> JSFunction String--- > example = ffi "$(%1).prop('checked',%2)"------ The 'ffi' function takes a string argument representing the JavaScript--- code to be executed on the client.--- Occurrences of the substrings @%1@ to @%9@ will be replaced by--- subequent arguments.------ Note: Always specify a type signature! The types automate--- how values are marshalled between Haskell and JavaScript.--- The class instances for the 'FFI' class show which conversions are supported.----ffi :: FFI a => String -> a-ffi macro = fancy (apply macro)--testFFI :: String -> Int -> JSFunction String-testFFI = ffi "$(%1).prop('checked',%2)"---- | String substitution.--- Substitute occurences of %1, %2 up to %9 with the argument strings.--- The types ensure that the % character has no meaning in the generated output.--- --- > apply "%1 and %2" [x,y] = x ++ " and " ++ y-apply :: String -> [JSCode] -> JSCode-apply code args = JSCode $ go code- where- argument i = unJSCode (args !! i)- - go [] = []- go ('%':c:cs) = argument index ++ go cs- where index = fromEnum c - fromEnum '1'- go (c:cs) = c : go cs
src/Graphics/UI/Threepenny/JQuery.hs view
@@ -6,7 +6,7 @@ import Data.Default import Data.Maybe import Graphics.UI.Threepenny.Core-import qualified Graphics.UI.Threepenny.Internal.Core as Core+import qualified Graphics.UI.Threepenny.Internal.Driver as Core import qualified Graphics.UI.Threepenny.Internal.Types as Core import Text.JSON import Reactive.Threepenny@@ -20,10 +20,10 @@ -- | Animate property changes of a function. animate :: Element -> [(String,String)] -> Int -> Easing -> IO () -> IO () animate el props duration easing complete =- flip updateElement el $ \(Core.Element el window) ->+ Core.withElement (toElement el) $ \elid window -> callDeferredFunction window "jquery_animate"- [encode el,encode (makeObj (map (second showJSON) props)),show duration,map toLower (show easing)]+ [encode elid,encode (makeObj (map (second showJSON) props)),show duration,map toLower (show easing)] (const complete) -- | Fade in an element.@@ -43,11 +43,9 @@ f (EventData x) = concat . catMaybes $ x -- | Focus an element.-setFocus :: Element -> IO ()-setFocus = updateElement $ \(Core.Element el window) ->- runFunction window (ffi "$(%1).focus()" el)+setFocus :: Element -> UI ()+setFocus = runFunction . ffi "$(%1).focus()" -- | Scroll to the bottom of an element.-scrollToBottom :: Element -> IO ()-scrollToBottom = updateElement $ \(Core.Element area window) ->- runFunction window (ffi "jquery_scrollToBottom(%1)" area)+scrollToBottom :: Element -> UI ()+scrollToBottom = runFunction . ffi "jquery_scrollToBottom(%1)"
src/Graphics/UI/Threepenny/Timer.hs view
@@ -28,8 +28,8 @@ } deriving (Typeable) -- | Create a new timer-timer :: IO Timer-timer = do+timer :: UI Timer+timer = liftIO $ do tvRunning <- newTVarIO False tvInterval <- newTVarIO 1000 (tTick, fire) <- newEvent@@ -60,11 +60,11 @@ running = fromGetSet tRunning -- | Start the timer.-start :: Timer -> IO ()+start :: Timer -> UI () start = set' running True -- | Stop the timer.-stop :: Timer -> IO ()+stop :: Timer -> UI () stop = set' running False fromTVar :: TVar a -> GetSet a a@@ -73,15 +73,18 @@ 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)+fromGetSet f = mkReadWriteAttr (liftIO . fst . f) (\i x -> liftIO $ snd (f x) i) {----------------------------------------------------------------------------- Small test ------------------------------------------------------------------------------}+{-+ testTimer = do t <- timer void $ register (tick t) $ const $ putStr "Hello" return t # set interval 1000 # set running True+-}
+ src/Graphics/UI/Threepenny/Widgets.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE RecordWildCards, ScopedTypeVariables #-}+module Graphics.UI.Threepenny.Widgets (+ -- * Synopsis+ -- | Widgets are reusable building blocks for a graphical user interface.+ -- This module collects useful widgets that are designed to work+ -- with functional reactive programming (FRP).+ -- + -- For more details and information on how to write your own widgets, see the+ -- <https://github.com/HeinrichApfelmus/threepenny-gui/blob/master/doc/design-widgets.md+ -- widget design guide>.+ + -- * Tidings+ Tidings, rumors, facts, tidings,+ -- * Widgets+ -- ** Input widgets+ TextEntry, entry, userText,+ -- ** ListBox+ ListBox, listBox, userSelection,+ ) where++import Control.Monad (void, when)+import qualified Data.Map as Map++import qualified Graphics.UI.Threepenny.Attributes as UI+import qualified Graphics.UI.Threepenny.Events as UI+import qualified Graphics.UI.Threepenny.Elements as UI+import Graphics.UI.Threepenny.Core+import Reactive.Threepenny++{-----------------------------------------------------------------------------+ Input widgets+------------------------------------------------------------------------------}+-- | A single-line text entry.+data TextEntry = TextEntry+ { _elementTE :: Element+ , _userTE :: Tidings String+ }++instance Widget TextEntry where getElement = _elementTE++-- | User changes to the text value.+userText :: TextEntry -> Tidings String+userText = _userTE++-- | Create a single-line text entry.+entry+ :: Behavior String -- ^ Display value when the element does not have focus.+ -> UI TextEntry+entry bValue = do -- single text entry+ input <- UI.input++ bEditing <- stepper False $ and <$>+ unions [True <$ UI.focus input, False <$ UI.blur input]+ + window <- askWindow+ liftIOLater $ onChange bValue $ \s -> runUI window $ do+ editing <- liftIO $ currentValue bEditing+ when (not editing) $ void $ element input # set value s++ let _elementTE = input+ _userTE = tidings bValue $ UI.valueChange input + return TextEntry {..}++{-----------------------------------------------------------------------------+ List box+------------------------------------------------------------------------------}+-- | A list of values. The user can select entries.+data ListBox a = ListBox+ { _elementLB :: Element+ , _selectionLB :: Tidings (Maybe a)+ }++instance Widget (ListBox a) where getElement = _elementLB++-- | User changes to the current selection (possibly empty).+userSelection :: ListBox a -> Tidings (Maybe a)+userSelection = _selectionLB++-- | Create a 'ListBox'.+listBox :: forall a. Ord a+ => Behavior [a] -- ^ list of items+ -> Behavior (Maybe a) -- ^ selected item+ -> Behavior (a -> UI Element) -- ^ display for an item+ -> UI (ListBox a)+listBox bitems bsel bdisplay = do+ list <- UI.select++ -- animate output items+ element list # sink items (map <$> bdisplay <*> bitems)++ -- animate output selection+ let bindices :: Behavior (Map.Map a Int)+ bindices = (Map.fromList . flip zip [0..]) <$> bitems+ bindex = lookupIndex <$> bindices <*> bsel++ lookupIndex indices Nothing = Nothing+ lookupIndex indices (Just sel) = Map.lookup sel indices++ element list # sink UI.selection bindex++ -- changing the display won't change the current selection+ -- eDisplay <- changes display+ -- sink listBox [ selection :== stepper (-1) $ bSelection <@ eDisplay ]++ -- user selection+ let bindices2 :: Behavior (Map.Map Int a)+ bindices2 = Map.fromList . zip [0..] <$> bitems++ _selectionLB = tidings bsel $+ lookupIndex <$> bindices2 <@> UI.selectionChange list+ _elementLB = list++ return ListBox {..}++items = mkWriteAttr $ \i x -> void $ do+ return x # set children [] #+ map (\i -> UI.option #+ [i]) i++++
src/Graphics/UI/driver.js view
@@ -39,7 +39,7 @@ //////////////////////////////////////////////////////////////////////////////// // State var sessionToken = null;- var element_count = 0, el_table = {};+ var el_table = {}; var tp_enable_log = $.cookie('tp_log') == "true"; var signal_count = 0; @@ -160,8 +160,13 @@ ws.close(); }); - var sendEvent = function (e) {- ws.send(JSON.stringify({ Event : e}));+ var sendEvent = function (elid, key, params) {+ ws.send(JSON.stringify({ Event : + { Element : { Element : elid }+ , EventId : key+ , Params : params+ }+ })); } var reply = function (response) { if (response != undefined)@@ -202,26 +207,17 @@ console_log("Event: %s",JSON.stringify(event)); for(var key in event){ switch(key){- - case "EmptyEl": {- var id = event.EmptyEl;- var el = elidToElement(id);- // Detach child elements without deleting associated event handlers and data.- // 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();- reply();- break;- }+ case "CallDeferredFunction": {- var call = event.CallDeferredFunction;- var closure = call[0];+ // FIXME: CallDeferredFunction probably doesn't work right now.+ var call = event.CallDeferredFunction;+ var closure = call[0]; var theFunction = eval(call[1]);- var params = call[2];+ var params = call[2]; theFunction.apply(window, params.concat(function(){ console_log(this); var args = Array.prototype.slice.call(arguments,0);- sendEvent(closure.concat([args]));+ sendEvent(closure[0],closure[1],args); })); reply(); break;@@ -237,7 +233,7 @@ break; } case "Delete": {- event_delete(event);+ deleteElid(event.Delete); reply(); break; }@@ -247,74 +243,6 @@ reply(); break; }- case "GetElementsByTagName": {- var elements = document.getElementsByTagName(event.GetElementsByTagName);- var els = [];- var len = elements.length;- for(var i = 0; i < len; i++) {- els.push({- Element: elementToElid(elements[i])- });- }- reply({ Elements: els });- break;- }- case "GetElementsById": {- // Note that this is the html ID, not the elid that is the key of the el_table.- var ids = event.GetElementsById;- var els = [];- for(var i = 0; i < ids.length; i++) {- var match = document.getElementById(ids[i]);- if (match != null) {- els.push({- Element: elementToElid(match)- });- }- }- 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];- var style = set[1];- var el = elidToElement(id);- var len = style.length;- for(var i = 0; i < len; i++){- el.style[style[i][0]] = style[i][1];- }- reply();- break;- }- case "SetAttr": {- var set = event.SetAttr;- var id = set[0];- var key = set[1];- var value = set[2];- var el = elidToElement(id);- $(el).attr(key,value);- reply();- break;- }- case "GetValue": {- var id = event.GetValue;- var el = elidToElement(id);- var value = $(el).val();- reply({ Value: value });- break;- } case "GetValues": { var ids = event.GetValues; var len = ids.length;@@ -325,66 +253,46 @@ reply({ Values: values }); break; }- case "Append": {- var append = event.Append;- $(elidToElement(append[0])).append($(elidToElement(append[1])));- reply();- break;- }- case "SetText": {- var set = event.SetText;- $(elidToElement(set[0])).text(set[1]);- reply();- break;- }- case "SetTitle": {- document.title = event.SetTitle;- reply();- break;- }- case "SetHtml": {- var set = event.SetHtml;- $(elidToElement(set[0])).html(set[1]);- reply();- break;- } case "Bind": { var bind = event.Bind; var eventType = bind[0];- var handlerGuid = bind[2];- var el = elidToElement(bind[1]);+ var elid = bind[1];+ var el = elidToElement(elid); console_log('event type: ' + eventType); if(eventType == 'livechange') { $(el).livechange(300,function(e){- sendEvent( handlerGuid.concat([[$(el).val()]]) );+ sendEvent(elid,eventType, [$(el).val()]); return true; }); } else if(eventType == 'sendvalue') { $(el).sendvalue(function(x){- sendEvent( handlerGuid.concat([[x]]) );+ sendEvent(elid,eventType, [x]); }); } else if(eventType.match('dragstart|dragenter|dragover|dragleave|drag|drop|dragend')) { $(el).bind(eventType,function(e){- sendEvent( handlerGuid.concat([+ sendEvent(elid,eventType, e.originalEvent.dataTransfer- ?[e.originalEvent.dataTransfer.getData("dragData")]- :[]])+ ? [e.originalEvent.dataTransfer.getData("dragData")]+ : [] ); return true; });- } else if(eventType.match('mousemove')) {+ } else if(eventType.match('mousemove|mousedown|mouseup')) { $(el).bind(eventType,function(e){- sendEvent( handlerGuid.concat([[e.pageX.toString(), e.pageY.toString()]]) );+ var offset = $(this).offset();+ var x = e.pageX - offset.left;+ var y = e.pageY - offset.top; + sendEvent(elid,eventType, [x.toString(), y.toString()]); return true; }); } else if(eventType.match('keydown|keyup')) { $(el).bind(eventType,function(e){- sendEvent( handlerGuid.concat([[e.keyCode.toString()]]) );+ sendEvent(elid,eventType, [e.keyCode.toString()]); return true; }); } else { $(el).bind(eventType,function(e){- sendEvent( handlerGuid.concat([e.which?[e.which.toString()]:[]]) );+ sendEvent(elid,eventType, e.which ? [e.which.toString()] : []); return true; }); }@@ -408,9 +316,9 @@ return document.body; else if(elid == 'head') return document.head;- else if(el_table[elid]){+ else if(el_table[elid]) return el_table[elid];- } else {+ else { if(elid[0] == '*'){ var create = elid.split(':'); var element = document.createElement(create[1]);@@ -422,44 +330,47 @@ } } }- function deleteElementTable(elid){- delete el_table[elid];- }- + // Get/generate a elid for an element. This function is used for cases in which the // element is accessed without knowing an elid from the server, such as when the // element is retrieved by type or html ID attribute. The element is then added to // elid lookup table using the new elid. // Note: The mapping between elids and DOM elements must be bijective. function elementToElid(element){- if(element.elid) {- return element.elid;- }- else if (element === document.body) {- return "body";+ if(element.elid)+ return element.elid;+ else if (element === document.body)+ return "body";+ else if (element === document.head)+ return "head";+ else {+ throw "Element requested, but does not have elid: " + element; }- else if (element === document.head) {- return "head";+ }+ + // plural of the mapping from elements to elids+ function elementsToElids(elements){+ var els = [], match;+ for(var i = 0; i < elements.length; i++) {+ match = elements[i];+ if (match != null) {+ els.push({ Element: elementToElid(match) });+ } }- else {- var elid = "!" + element_count.toString();- element_count++;- element.elid = elid;- el_table[elid] = element;- return elid;+ return els;+ }+ + // Delete element from the table+ function deleteElid(elid){+ var el = el_table[elid];+ if (el) {+ $(el).detach(); // Should be detached already, but make sure+ delete el_table[elid]; } } //////////////////////////////////////////////////////////////////////////////// // 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));
− src/MissingDollars.hs
@@ -1,140 +0,0 @@-{-# LANGUAGE CPP, PackageImports #-}--import Control.Monad-import Safe--#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-import Paths--{------------------------------------------------------------------------------ Missing Dollars-------------------------------------------------------------------------------}-main :: IO ()-main = do- static <- getStaticDir- startGUI defaultConfig- { tpPort = 10000- , tpStatic = Just static- } setup---setup :: Window -> IO ()-setup w = void $ do- return w # set title "Missing Dollars"- UI.addStyleSheet w "missing-dollars.css"- - (headerView,headerMe) <- mkHeader- riddle <- mkMissingDollarRiddle headerMe- let layout = [element headerView] ++ riddle ++ attributionSource - getBody w #+ [UI.div #. "wrap" #+ layout]---mkHeader :: IO (Element, Element)-mkHeader = do- headerMe <- string "..."- view <- UI.h1 #+ [string "The ", element headerMe, string " Dollars"]- return (view, headerMe)--attributionSource :: [IO Element]-attributionSource =- [ UI.p #+- [ UI.anchor #. "view-source" # set UI.href urlSource- #+ [string "View source code"]- ]- , UI.p #+- [ string "Originally by "- , UI.anchor # set UI.href urlAttribution #+ [string "Albert Lai"]- ]- ]- where- urlSource = "https://github.com/HeinrichApfelmus/threepenny-gui/blob/master/src/MissingDollars.hs"- urlAttribution = "http://www.vex.net/~trebla/humour/missing_dollar.html"---mkMissingDollarRiddle :: Element -> IO [IO Element]-mkMissingDollarRiddle headerMe = do- -- declare input and display values- (hotelOut : hotelCost : hotelHold : _)- <- sequence . replicate 3 $- UI.input # set (attr "size") "3" # set (attr "type") "text"-- (hotelChange : hotelRet : hotelBal : hotelPocket :- hotelBal2 : hotelPocket2 : hotelSum : hotelMe : _)- <- sequence . replicate 8 $ UI.span- - -- update procedure- let updateDisplay out cost hold = do- let change = out - cost- ret = change - hold- bal = out - ret- sum = bal + hold- diff = sum - out- element hotelOut # set value (show out)- element hotelCost # set value (show cost)- element hotelHold # set value (show hold)- element hotelChange # set text (show change)- element hotelRet # set text (show ret)- element hotelBal # set text (show bal)- element hotelPocket # set text (show hold)- element hotelBal2 # set text (show bal)- element hotelPocket2 # set text (show hold)- element hotelSum # set text (show sum)- - if diff >= 0- then do element hotelMe # set text ("extra $" ++ show diff ++ " come from")- element headerMe # set text "Extra"- else do element hotelMe # set text ("missing $" ++ show (-diff) ++ " go")- element headerMe # set text "Missing"- return ()- - -- initialize values- updateDisplay 30 25 2- - -- calculate button- calculate <- UI.button #+ [string "Calculate"]- on UI.click calculate $ \_ -> do- result <- mapM readMay `liftM` getValuesList [hotelOut,hotelCost,hotelHold]- case result of- Just [getout,getcost,gethold] -> updateDisplay getout getcost gethold- _ -> return ()- - return $- [ UI.h2 #+ [string "The Guests, The Bellhop, And The Pizza"]- , UI.p #+- [ string "Three guests went to a hotel and gave $"- , element hotelOut- , string " to the bellhop to buy pizza. The pizza cost only $"- , element hotelCost- , string ". Of the $"- , element hotelChange- , string " change, the bellhop kept $"- , element hotelHold- , string " to himself and returned $"- , element hotelRet- , string " to the guests."- ]- , UI.p #+- [ string "So the guests spent $"- , element hotelBal- , string ", and the bellhop pocketed $"- , element hotelPocket- , string ". Now "- , string "$"- , element hotelBal2- , string "+$"- , element hotelPocket2- , string "=$"- , element hotelSum- , string ". Where did the "- , element hotelMe- , string "?"- ]- , element calculate- ] -
− src/Paths.hs
@@ -1,20 +0,0 @@-{-# LANGUAGE CPP#-}-module Paths (getStaticDir) where--import Control.Monad-import System.FilePath--#if CABAL--- using cabal-import qualified Paths_threepenny_gui (getDataDir)--getStaticDir :: IO FilePath-getStaticDir = (</> "wwwroot") `liftM` Paths_threepenny_gui.getDataDir--#else--- using GHCi--getStaticDir :: IO FilePath-getStaticDir = return "../wwwroot/"--#endif
src/Reactive/Threepenny.hs view
@@ -35,6 +35,9 @@ -- * Additional Notes -- $recursion + -- * Tidings+ Tidings, tidings, facts, rumors,+ -- * Internal -- | Functions reserved for special circumstances. -- Do not use unless you know what you're doing.@@ -43,6 +46,7 @@ import Control.Applicative import Control.Monad (void)+import Control.Monad.IO.Class import Data.IORef import qualified Data.Map as Map @@ -140,8 +144,8 @@ register e (\_ -> h =<< Prim.readLatch l) -- | Read the current value of a 'Behavior'.-currentValue :: Behavior a -> IO a-currentValue (B l _) = Prim.readLatch l+currentValue :: MonadIO m => Behavior a -> m a+currentValue (B l _) = liftIO $ Prim.readLatch l {-----------------------------------------------------------------------------@@ -150,7 +154,8 @@ instance Functor Event where fmap f e = E $ liftMemo1 (Prim.mapP f) (unE e) -unsafeMapIO f e = E $ liftMemo1 (Prim.unsafeMapIOP f) (unE e)+unsafeMapIO :: (a -> IO b) -> Event a -> Event b+unsafeMapIO f e = E $ liftMemo1 (Prim.unsafeMapIOP f) (unE e) -- | Event that never occurs. -- Think of it as @never = []@.@@ -201,8 +206,8 @@ -- -- 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+accumB :: MonadIO m => a -> Event (a -> a) -> m (Behavior a)+accumB a e = liftIO $ do (l1,p1) <- Prim.accumL a =<< at (unE e) p2 <- Prim.mapP (const ()) p1 return $ B l1 (E $ fromPure p2)@@ -217,7 +222,7 @@ -- 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 :: MonadIO m => a -> Event a -> m (Behavior a) stepper a e = accumB a (const <$> e) -- | The 'accumE' function accumulates a stream of events.@@ -228,8 +233,8 @@ -- -- 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+accumE :: MonadIO m => a -> Event (a -> a) -> m (Event a)+accumE a e = liftIO $ do p <- fmap snd . Prim.accumL a =<< at (unE e) return $ E $ fromPure p @@ -327,11 +332,41 @@ -} -- | Efficient combination of 'accumE' and 'accumB'.-mapAccum :: acc -> Event (acc -> (x,acc)) -> IO (Event x, Behavior acc)+mapAccum :: MonadIO m => acc -> Event (acc -> (x,acc)) -> m (Event x, Behavior acc) mapAccum acc ef = do e <- accumE (undefined,acc) ((. snd) <$> ef) b <- stepper acc (snd <$> e) return (fst <$> e, b)+++{-----------------------------------------------------------------------------+ Tidings+------------------------------------------------------------------------------}+-- | Data type representing a behavior ('facts')+-- and suggestions to change it ('rumors').+data Tidings a = T { facts :: Behavior a, rumors :: Event a }++-- | Smart constructor. Combine facts and rumors into 'Tidings'.+tidings :: Behavior a -> Event a -> Tidings a+tidings b e = T b e++instance Functor Tidings where+ fmap f (T b e) = T (fmap f b) (fmap f e)++-- | The applicative instance combines 'rumors'+-- and uses 'facts' when some of the 'rumors' are not available.+instance Applicative Tidings where+ pure x = T (pure x) never+ f <*> x = uncurry ($) <$> pair f x++pair :: Tidings a -> Tidings b -> Tidings (a,b)+pair (T bx ex) (T by ey) = T b e+ where+ b = (,) <$> bx <*> by+ x = flip (,) <$> by <@> ex+ y = (,) <$> bx <@> ey+ e = unionWith (\(x,_) (_,y) -> (x,y)) x y+ {----------------------------------------------------------------------------- Test
+ src/Reactive/Threepenny/Monads.hs view
@@ -0,0 +1,12 @@+module Reactive.Threepenny.Monads where++import Control.Monad.Trans.RWS.Lazy+import Reactive.Threepenny.Types++{-----------------------------------------------------------------------------+ EvalP - evaluate pulses+------------------------------------------------------------------------------}+runEvalP :: Values -> EvalP a -> IO (a, Values)+runEvalP pulses m = do+ (a, s, w) <- runRWST m () pulses+ return (a, s)
src/Reactive/Threepenny/PulseLatch.hs view
@@ -14,48 +14,29 @@ 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+import Data.Hashable+import qualified Data.HashMap.Strict as Map+import qualified Data.Vault.Strict as Vault+import Data.Unique.Really +import Reactive.Threepenny.Monads+import Reactive.Threepenny.Types -type Build = IO+type Map = Map.HashMap {----------------------------------------------------------------------------- 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+ , evalP = do vault <- Monad.get case Vault.lookup key vault of Just a -> return a@@ -76,11 +57,6 @@ case ma of Just a -> return (f a) Nothing -> return $ return ()--{------------------------------------------------------------------------------ Latch-------------------------------------------------------------------------------}-data Latch a = Latch { readL :: IO a } {----------------------------------------------------------------------------- Interface to the outside world.
+ src/Reactive/Threepenny/Types.hs view
@@ -0,0 +1,39 @@+module Reactive.Threepenny.Types where++import Control.Monad.Trans.RWS.Lazy+import Data.Functor.Identity++import Data.Hashable+import qualified Data.Vault.Strict as Vault.Strict+import Data.Unique.Really++{-----------------------------------------------------------------------------+ Pulse and Latch+------------------------------------------------------------------------------}+type Values = Vault.Strict.Vault++type Handler = EvalP (IO ())+data Priority = DoLatch | DoIO deriving (Eq,Show,Ord,Enum)++data Pulse a = Pulse+ { addHandlerP :: ((Unique, Priority), Handler) -> Build ()+ , evalP :: EvalP (Maybe a)+ }++instance Hashable Priority where hashWithSalt _ = fromEnum++data Latch a = Latch { readL :: EvalL a }++{-----------------------------------------------------------------------------+ Monads+------------------------------------------------------------------------------}+-- | The 'EvalP' monad is used to evaluate pulses.+type EvalP = RWST () () Values BuildIO+ -- state: current pulse values++-- | The 'EvalL' monad is used to evaluate latches.+type EvalL = IO++-- | The 'Build' monad is used to add pulses and latches to the graph.+type Build = IO+type BuildIO = Build
− src/UseWords.hs
@@ -1,109 +0,0 @@-{-# LANGUAGE CPP, PackageImports #-}-{-# LANGUAGE ViewPatterns #-}--module Main where--import Control.Applicative hiding ((<|>),many)-import Control.Monad-import Control.Arrow (second)-import Data.Maybe-import Text.Parsec--#ifdef CABAL-import qualified "threepenny-gui" Graphics.UI.Threepenny as UI-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, (<|>), many)-#endif-import Paths-import System.FilePath ((</>))--{------------------------------------------------------------------------------ GUI-------------------------------------------------------------------------------}-main :: IO ()-main = do- static <- getStaticDir- startGUI defaultConfig- { tpPort = 10000- , tpStatic = Just static- } setup---setup :: Window -> IO ()-setup w = do- filename <- fmap (</> "and-then-haskell.txt") getStaticDir - andthen <- readFile filename- case parts filename andthen of- Left parseerror -> debug w $ show parseerror- Right parts -> void $ do- UI.addStyleSheet w "use-words.css"-- let (header, Prelude.drop 2 -> rest) = splitAt 3 parts - - (views1, vars1) <- renderParts header- (views2, vars2) <- renderParts rest- varChoices <- mapM (renderVarChoice (vars1 ++ vars2)) vars- - getBody w #+- [ viewSource- , UI.div #. "wrap" #+ (- [ UI.div #. "header" #+ map element views1- , UI.ul #. "vars" #+ map element varChoices- ]- ++ map element views2 )- ]- -type VariableViews = [(Name, Element)]--renderVarChoice :: VariableViews -> Variable -> IO Element-renderVarChoice views (label,(name,def)) = do- input <- UI.input #. "var-value" # set value def- - on (domEvent "livechange") input $ \(EventData xs) -> do- let s = concat $ catMaybes xs- forM_ (filter ((==name).fst) views) $ \(_,el) -> do- element el # set text s- - UI.li #+ [UI.string (label ++ ":"), element input]--renderParts :: [Part] -> IO ([Element], VariableViews)-renderParts parts = do- views <- mapM renderPart parts- let variables = [(var, view) | (Ref var, view) <- zip parts views]- return (views, variables)--renderPart :: Part -> IO Element-renderPart (Text str) = UI.div #. "text" #+ [UI.string str]-renderPart (Ref var) = UI.div #. "var"- # maybe (set text $ "{" ++ var ++ "}") (either (set html) (set text))- (lookup var templatevars)--viewSource :: IO Element-viewSource = UI.p #+- [UI.anchor #. "view-source" # set UI.href url #+ [UI.string "View source code"]]- where- url = "https://github.com/HeinrichApfelmus/threepenny-gui/blob/master/src/UseWords.hs"--{------------------------------------------------------------------------------ Parsing-------------------------------------------------------------------------------}-type Name = String-type Variable = (String, (Name, String))--templatevars = map (second Right . snd) vars ++ map (second Left) exts--vars :: [Variable]-vars = [("Favourite technology",("favourite-language","Haskell"))- ,("Technology used at work",("work-language","Python"))- ,("Cool forum",("bar","LtU"))- ,("Particular to technology",("particular-stuff","monads"))]-exts = [("br","<br><br>")]--data Part = Text String | Ref String deriving Show--parts :: SourceName -> String -> Either ParseError [Part]-parts = parse (many (ref <|> text)) where- text = Text <$> many1 (notFollowedBy (string "{") *> anyChar)- ref = Ref <$> (string "{" *> many1 (noneOf "}") <* (string "}"))
threepenny-gui.cabal view
@@ -1,5 +1,5 @@ Name: threepenny-gui-Version: 0.3.0.1+Version: 0.4.0.0 Synopsis: GUI framework that uses the web browser as a display. Description: Threepenny-GUI is a GUI framework that uses the web browser as a display.@@ -18,25 +18,19 @@ To build and install the example, use the @buildExamples@ flag like this . @cabal install threepenny-gui -fbuildExamples@- .- Changelog:- .- * 0.3.0.0 - Snapshot release. Browser communication with WebSockets. First stab at FRP integration.- .- * 0.2.0.0 - Snapshot release. First stab at easy JavaScript FFI.- .- * 0.1.0.0 - Initial release. License: BSD3 License-file: LICENSE Author: Chris Done, Heinrich Apfelmus Maintainer: Heinrich Apfelmus <apfelmus at quantentunnel dot de> Homepage: http://www.haskell.org/haskellwiki/Threepenny-gui+bug-reports: https://github.com/HeinrichApfelmus/threepenny-gui/issues Category: Web, GUI Build-type: Simple Cabal-version: >=1.8 -Extra-Source-Files: src/Graphics/UI/*.html+Extra-Source-Files: CHANGELOG.md+ ,src/Graphics/UI/*.html ,src/Graphics/UI/*.js ,src/Graphics/UI/*.css @@ -52,16 +46,22 @@ description: Build example executables. default: False +flag rebug+ description: The library uses some techniques that are highly+ non-deterministic, for example garbage collection and concurrency.+ Bugs in these subsystems are harder to find.+ Activating this flag will expose more of them.+ default: False+ Source-repository head type: git location: git://github.com/HeinrichApfelmus/threepenny-gui.git Library- Hs-source-dirs: src- Exposed-modules:- Reactive.Threepenny- ,Graphics.UI.Threepenny+ hs-source-dirs: src+ exposed-modules:+ Graphics.UI.Threepenny ,Graphics.UI.Threepenny.Attributes ,Graphics.UI.Threepenny.Core ,Graphics.UI.Threepenny.Canvas@@ -70,40 +70,51 @@ ,Graphics.UI.Threepenny.Events ,Graphics.UI.Threepenny.JQuery ,Graphics.UI.Threepenny.Timer- Other-modules:+ ,Graphics.UI.Threepenny.Widgets+ ,Reactive.Threepenny+ ,Foreign.Coupon+ other-modules: Control.Concurrent.Chan.Extra ,Control.Concurrent.Delay- ,Graphics.UI.Threepenny.Internal.Core- ,Graphics.UI.Threepenny.Internal.Resources+ ,Graphics.UI.Threepenny.Internal.Driver+ ,Graphics.UI.Threepenny.Internal.FFI ,Graphics.UI.Threepenny.Internal.Include+ ,Graphics.UI.Threepenny.Internal.Resources ,Graphics.UI.Threepenny.Internal.Types- ,Reactive.Threepenny.PulseLatch ,Reactive.Threepenny.Memo+ ,Reactive.Threepenny.Monads+ ,Reactive.Threepenny.PulseLatch+ ,Reactive.Threepenny.Types ,Paths_threepenny_gui- CPP-Options: -DCABAL- Build-depends: base >= 4 && < 5- ,snap-server- ,snap-core- ,websockets == 0.7.*- ,websockets-snap == 0.7.*- ,text- ,safe- ,containers- ,unordered-containers- ,hashable- ,vault == 0.3.*- ,bytestring- ,json >= 0.4.4 && < 0.6- ,time- ,utf8-string- ,network- ,filepath- ,data-default- ,template-haskell- ,transformers- ,stm- ,attoparsec-enumerator- ,MonadCatchIO-transformers+ extensions: CPP+ cpp-options: -DCABAL+ if flag(rebug)+ cpp-options: -DREBUG+ ghc-options: -O2 + build-depends: base >= 4 && < 5+ ,attoparsec-enumerator == 0.3.*+ ,bytestring >= 0.9.2 && < 0.11+ ,containers >= 0.4.2 && < 0.6+ ,data-default == 0.5.*+ ,deepseq == 1.3.*+ ,filepath == 1.3.*+ ,hashable >= 1.1.0 && < 1.3+ ,json >= 0.4.4 && < 0.6+ ,MonadCatchIO-transformers == 0.3.*+ ,network >= 2.3.0 && < 2.5+ ,safe == 0.3.*+ ,snap-server == 0.9.*+ ,snap-core == 0.9.*+ ,stm >= 2.3 && < 2.5+ ,template-haskell >= 2.7.0 && < 2.9+ ,text == 0.11.*+ ,time == 1.4.*+ ,transformers == 0.3.*+ ,unordered-containers == 0.2.*+ ,utf8-string == 0.3.*+ ,websockets == 0.8.*+ ,websockets-snap == 0.8.*+ ,vault == 0.3.* Executable threepenny-examples-bartab if flag(buildExamples)@@ -115,7 +126,7 @@ buildable: False main-is: BarTab.hs other-modules: Paths_threepenny_gui, Paths- hs-source-dirs: src+ hs-source-dirs: samples Executable threepenny-examples-buttons if flag(buildExamples)@@ -127,8 +138,34 @@ buildable: False main-is: Buttons.hs other-modules: Paths_threepenny_gui, Paths- hs-source-dirs: src+ hs-source-dirs: samples +Executable threepenny-examples-chat+ if flag(buildExamples)+ cpp-options: -DCABAL+ build-depends: base >= 4 && < 5+ ,threepenny-gui+ ,transformers+ ,filepath+ ,time+ else+ buildable: False+ main-is: Chat.hs+ other-modules: Paths_threepenny_gui, Paths, Data.List.Extra+ hs-source-dirs: samples++Executable threepenny-examples-crud+ if flag(buildExamples)+ cpp-options: -DCABAL+ build-depends: base >= 4 && < 5+ ,containers+ ,threepenny-gui+ else+ buildable: False+ main-is: CRUD.hs+ other-modules: Tidings+ hs-source-dirs: samples+ Executable threepenny-examples-currencyconverter if flag(buildExamples) cpp-options: -DCABAL@@ -138,7 +175,7 @@ else buildable: False main-is: CurrencyConverter.hs- hs-source-dirs: src+ hs-source-dirs: samples Executable threepenny-examples-dragndropexample if flag(buildExamples)@@ -150,7 +187,7 @@ buildable: False main-is: DragNDropExample.hs other-modules: Paths_threepenny_gui, Paths- hs-source-dirs: src+ hs-source-dirs: samples Executable threepenny-examples-drummachine if flag(buildExamples)@@ -162,7 +199,7 @@ buildable: False main-is: DrumMachine.hs other-modules: Paths_threepenny_gui, Paths- hs-source-dirs: src+ hs-source-dirs: samples Executable threepenny-examples-missing-dollars if flag(buildExamples)@@ -175,7 +212,7 @@ buildable: False main-is: MissingDollars.hs other-modules: Paths_threepenny_gui, Paths- hs-source-dirs: src+ hs-source-dirs: samples Executable threepenny-examples-use-words if flag(buildExamples)@@ -188,18 +225,4 @@ buildable: False main-is: UseWords.hs other-modules: Paths_threepenny_gui, Paths- hs-source-dirs: src--Executable threepenny-examples-chat- if flag(buildExamples)- cpp-options: -DCABAL- build-depends: base >= 4 && < 5- ,threepenny-gui- ,transformers- ,filepath- ,time- else- buildable: False- main-is: Chat.hs- other-modules: Paths_threepenny_gui, Paths, Data.List.Extra- hs-source-dirs: src+ hs-source-dirs: samples