diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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 +Copyright (c) 2013, Daniel Austin +Copyright (c) 2013, Daniel Mlot +Copyright (c) 2013, Rnons +Copyright (c) 2012, Jeremy Bowers +Copyright (c) 2011-2012, Chris Done All rights reserved. Redistribution and use in source and binary forms, with or without diff --git a/samples/BarTab.hs b/samples/BarTab.hs new file mode 100644 --- /dev/null +++ b/samples/BarTab.hs @@ -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 diff --git a/samples/Buttons.hs b/samples/Buttons.hs new file mode 100644 --- /dev/null +++ b/samples/Buttons.hs @@ -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 "Delayed 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" + diff --git a/samples/CRUD.hs b/samples/CRUD.hs new file mode 100644 --- /dev/null +++ b/samples/CRUD.hs @@ -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 + ) diff --git a/samples/Chat.hs b/samples/Chat.hs new file mode 100644 --- /dev/null +++ b/samples/Chat.hs @@ -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" diff --git a/samples/CurrencyConverter.hs b/samples/CurrencyConverter.hs new file mode 100644 --- /dev/null +++ b/samples/CurrencyConverter.hs @@ -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 + diff --git a/samples/Data/List/Extra.hs b/samples/Data/List/Extra.hs new file mode 100644 --- /dev/null +++ b/samples/Data/List/Extra.hs @@ -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 diff --git a/samples/DragNDropExample.hs b/samples/DragNDropExample.hs new file mode 100644 --- /dev/null +++ b/samples/DragNDropExample.hs @@ -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) + diff --git a/samples/DrumMachine.hs b/samples/DrumMachine.hs new file mode 100644 --- /dev/null +++ b/samples/DrumMachine.hs @@ -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) + diff --git a/samples/MissingDollars.hs b/samples/MissingDollars.hs new file mode 100644 --- /dev/null +++ b/samples/MissingDollars.hs @@ -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 + ] + diff --git a/samples/Paths.hs b/samples/Paths.hs new file mode 100644 --- /dev/null +++ b/samples/Paths.hs @@ -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 diff --git a/samples/Tidings.hs b/samples/Tidings.hs new file mode 100644 --- /dev/null +++ b/samples/Tidings.hs @@ -0,0 +1,37 @@ +module Tidings ( + -- * Synopsis + -- The 'Tidings' data type for composing user events. + -- + -- See + -- 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 diff --git a/samples/UseWords.hs b/samples/UseWords.hs new file mode 100644 --- /dev/null +++ b/samples/UseWords.hs @@ -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","

")] + +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 "}")) diff --git a/src/BarTab.hs b/src/BarTab.hs deleted file mode 100644 --- a/src/BarTab.hs +++ /dev/null @@ -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 diff --git a/src/Buttons.hs b/src/Buttons.hs deleted file mode 100644 --- a/src/Buttons.hs +++ /dev/null @@ -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 "Delayed 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" - diff --git a/src/Chat.hs b/src/Chat.hs deleted file mode 100644 --- a/src/Chat.hs +++ /dev/null @@ -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" diff --git a/src/CurrencyConverter.hs b/src/CurrencyConverter.hs deleted file mode 100644 --- a/src/CurrencyConverter.hs +++ /dev/null @@ -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 - diff --git a/src/Data/List/Extra.hs b/src/Data/List/Extra.hs deleted file mode 100644 --- a/src/Data/List/Extra.hs +++ /dev/null @@ -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 diff --git a/src/DragNDropExample.hs b/src/DragNDropExample.hs deleted file mode 100644 --- a/src/DragNDropExample.hs +++ /dev/null @@ -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) - diff --git a/src/DrumMachine.hs b/src/DrumMachine.hs deleted file mode 100644 --- a/src/DrumMachine.hs +++ /dev/null @@ -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) - diff --git a/src/Foreign/Coupon.hs b/src/Foreign/Coupon.hs new file mode 100644 --- /dev/null +++ b/src/Foreign/Coupon.hs @@ -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 diff --git a/src/Graphics/UI/Threepenny.hs b/src/Graphics/UI/Threepenny.hs --- a/src/Graphics/UI/Threepenny.hs +++ b/src/Graphics/UI/Threepenny.hs @@ -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 -. +. -} diff --git a/src/Graphics/UI/Threepenny/Canvas.hs b/src/Graphics/UI/Threepenny/Canvas.hs --- a/src/Graphics/UI/Threepenny/Canvas.hs +++ b/src/Graphics/UI/Threepenny/Canvas.hs @@ -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()" diff --git a/src/Graphics/UI/Threepenny/Core.hs b/src/Graphics/UI/Threepenny/Core.hs --- a/src/Graphics/UI/Threepenny/Core.hs +++ b/src/Graphics/UI/Threepenny/Core.hs @@ -1,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 diff --git a/src/Graphics/UI/Threepenny/Elements.hs b/src/Graphics/UI/Threepenny/Elements.hs --- a/src/Graphics/UI/Threepenny/Elements.hs +++ b/src/Graphics/UI/Threepenny/Elements.hs @@ -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 {----------------------------------------------------------------------------- diff --git a/src/Graphics/UI/Threepenny/Events.hs b/src/Graphics/UI/Threepenny/Events.hs --- a/src/Graphics/UI/Threepenny/Events.hs +++ b/src/Graphics/UI/Threepenny/Events.hs @@ -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 @