threepenny-gui 0.1.0.1 → 0.2.0.0

raw patch · 20 files changed

+630/−166 lines, 20 filesdep +stmnew-component:exe:threepenny-examples-drummachinebinary-addedPVP ok

version bump matches the API change (PVP)

Dependencies added: stm

API changes (from Hackage documentation)

Files

• src/Buttons.hs +2/−3
• src/DrumMachine.hs +108/−0
• src/Graphics/UI/Threepenny.hs +4/−0
• src/Graphics/UI/Threepenny/Attributes.hs +36/−17
• src/Graphics/UI/Threepenny/Canvas.hs +35/−0
• src/Graphics/UI/Threepenny/Core.hs +29/−15
• src/Graphics/UI/Threepenny/Elements.hs +13/−10
• src/Graphics/UI/Threepenny/Events.hs +27/−1
• src/Graphics/UI/Threepenny/Internal/Core.hs +84/−55
• src/Graphics/UI/Threepenny/Internal/Types.hs +122/−23
• src/Graphics/UI/Threepenny/JQuery.hs +2/−2
• src/Graphics/UI/Threepenny/Timer.hs +76/−0
• src/Graphics/UI/driver.js +65/−39
• threepenny-gui.cabal +27/−1
• wwwroot/css/fade.png binary
• wwwroot/css/stripes-bg.png binary
• wwwroot/css/wood-bg.png binary
• wwwroot/hihat.wav binary
• wwwroot/kick.wav binary
• wwwroot/snare.wav binary

@@ -1,6 +1,5 @@ {-# LANGUAGE CPP, PackageImports #-} - import Control.Monad import Control.Concurrent (threadDelay) @@ -59,8 +58,8 @@     on UI.leave button1 $ \_ -> do         element button1 # set text button1Title     on UI.click button1 $ \_ -> do-        threadDelay $ 1000 * 1000 * 1         element button1 # set text (button1Title ++ " [pressed]")+        threadDelay $ 1000 * 1000 * 1         element list    #+ [UI.li # set html "<b>Delayed</b> result!"]          (button2, view2) <- mkButton button2Title@@ -70,7 +69,7 @@     on UI.leave button2 $ \_ -> do         element button2 # set text button2Title     on UI.click button2 $ \_ -> do-        element button1 # set text (button1Title ++ " [pressed]")+        element button2 # set text (button2Title ++ " [pressed]")         element list    #+ [UI.li # set html "Zap! Quick result!"]          return [list, view1, view2]

@@ -0,0 +1,108 @@+{-# 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 Config+        { tpPort       = 10000+        , tpCustomHTML = Nothing+        , tpStatic     = 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)+    refBeat <- newIORef 0+    +    -- play sounds on timer events+    on UI.tick timer $ const $ void $ do+        -- get and increase beat count+        beat <- readIORef refBeat+        writeIORef refBeat $ (beat + 1) `mod` (beats * bars)+        element elTick # set text (show $ beat + 1)+        +        -- play corresponding sounds+        sequence_ $ map (!! beat) kit+    +    -- allow user to set BPM+    on (domEvent "livechange") elBpm $ const $ void $ do+        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 $ 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)+

@@ -1,15 +1,19 @@ module Graphics.UI.Threepenny (     module Graphics.UI.Threepenny.Attributes,     module Graphics.UI.Threepenny.Core,+    module Graphics.UI.Threepenny.Canvas,     module Graphics.UI.Threepenny.DragNDrop,     module Graphics.UI.Threepenny.Elements,     module Graphics.UI.Threepenny.Events,     module Graphics.UI.Threepenny.JQuery,+    module Graphics.UI.Threepenny.Timer,     ) where  import Graphics.UI.Threepenny.Attributes import Graphics.UI.Threepenny.Core+import Graphics.UI.Threepenny.Canvas import Graphics.UI.Threepenny.DragNDrop import Graphics.UI.Threepenny.Elements import Graphics.UI.Threepenny.Events import Graphics.UI.Threepenny.JQuery+import Graphics.UI.Threepenny.Timer

@@ -1,26 +1,53 @@ module Graphics.UI.Threepenny.Attributes (     -- * Synopsis-    -- | Element Attributes, for convenience.+    -- | Element attributes.     -    -- * Documentation+    -- * Input elements+    checked, selection, enabled,+    +    -- * HTML attributes     action, align, alink, alt, altcode, archive,     background, base, bgcolor, border, bordercolor,-    cellpadding, cellspacing, checked, class_, clear_, code, codebase,+    cellpadding, cellspacing, checked_, class_, clear_, code_, codebase,     color, cols, colspan, compact, content, coords,     enctype, face, frameborder, height, href, hspace, httpequiv,-    id_, ismap, lang, link, marginheight, marginwidth, maxlength, method, multiple,+    id_, ismap, lang, marginheight, marginwidth, maxlength, method, multiple,     name, nohref, noresize, noshade, nowrap,     rel, rev, rows, rowspan, rules,-    scrolling, selected, shape, size, src, start,+    scrolling, selected, shape, size, src,     target, text_, type_, usemap, valign, version, vlink, vspace, width,     ) where -+import Text.JSON import Graphics.UI.Threepenny.Core  {-----------------------------------------------------------------------------     Attributes ------------------------------------------------------------------------------}+-- | The @checked@ status of an input element of type checkbox.+checked :: Attr Element Bool+checked = fromProp "checked" (== JSBool True) JSBool++-- | The @enabled@ status of an input element+enabled :: Attr Element Bool+enabled = fromProp "disabled" (== JSBool False) (JSBool . not)++-- | Index of the currently selected option of a @<select>@ element.+--+-- The index starts at @0@.+-- If no option is selected, then the selection is 'Nothing'.+selection :: Attr Element (Maybe Int)+selection = fromProp "selectedIndex" from (showJSON . maybe (-1) id)+    where+    from s = let Ok x = readJSON s in if x == -1 then Nothing else Just x+++{-----------------------------------------------------------------------------+    HTML atributes+    +    Taken from the HTML library (BSD3 license)+    http://hackage.haskell.org/package/html+------------------------------------------------------------------------------} strAttr :: String -> WriteAttr Element String strAttr name = mkWriteAttr (set' (attr name)) @@ -32,13 +59,7 @@     where     f True  = "1"     f False = "0"--{------------------------------------------------------------------------------    Primitives     -    Taken from the HTML library (BSD3 license)-    http://hackage.haskell.org/package/html-------------------------------------------------------------------------------} action              =   strAttr "action" align               =   strAttr "align" alink               =   strAttr "alink"@@ -52,9 +73,9 @@ bordercolor         =   strAttr "bordercolor" cellpadding         =   intAttr "cellpadding" cellspacing         =   intAttr "cellspacing"-checked             = emptyAttr "checked"+checked_            = emptyAttr "checked" clear_              =   strAttr "clear"-code                =   strAttr "code"+code_               =   strAttr "code" codebase            =   strAttr "codebase" color               =   strAttr "color" cols                =   strAttr "cols"@@ -72,7 +93,6 @@ id_                 =   strAttr "id" ismap               = emptyAttr "ismap" lang                =   strAttr "lang"-link                =   strAttr "link" marginheight        =   intAttr "marginheight" marginwidth         =   intAttr "marginwidth" maxlength           =   intAttr "maxlength"@@ -93,7 +113,6 @@ shape               =   strAttr "shape" size                =   strAttr "size" src                 =   strAttr "src"-start               =   intAttr "start" target              =   strAttr "target" text_               =   strAttr "text" class_              =   strAttr "class"@@ -104,4 +123,4 @@ version             =   strAttr "version" vlink               =   strAttr "vlink" vspace              =   intAttr "vspace"-width               =   strAttr "width"+width               =   intAttr "width"

@@ -0,0 +1,35 @@+module Graphics.UI.Threepenny.Canvas (+    -- * Synopsis+    -- | Partial binding to the HTML5 canvas API.+    +    -- * Documentation+    Canvas,+    drawImage, clearCanvas,+    ) where++import Control.Event+import Graphics.UI.Threepenny.Core+import qualified Graphics.UI.Threepenny.Internal.Core as Core+import qualified Graphics.UI.Threepenny.Internal.Types as Core++{-----------------------------------------------------------------------------+    Canvas+------------------------------------------------------------------------------}+type Canvas = Element++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++-- | Clear the canvas+clearCanvas :: Canvas -> IO ()+clearCanvas = updateElement $ \(Core.Element canvas window) -> do+    runFunction window $+        ffi "%1.getContext('2d').clear()" canvas++

@@ -13,7 +13,7 @@     -- * DOM elements     -- | Create and manipulate DOM elements.     Element, mkElement, getWindow, delete, (#+), string,-        getHead, getBody, +        getHead, getBody,         children, text, html, attr, style, value,     getValuesList,     getElementsByTagName, getElementByTagName, getElementsById, getElementById,@@ -34,34 +34,33 @@     Attr, WriteAttr, ReadAttr, ReadWriteAttr(..),     set, get, mkReadWriteAttr, mkWriteAttr, mkReadAttr,     -    -- * Utilities-    -- | A few raw JavaScript utilities.+    -- * JavaScript FFI+    -- | Direct interface to JavaScript in the browser window.     debug, clear,-    callFunction, runFunction, callDeferredFunction,-    atomic,+    ToJS, FFI, ffi, JSFunction, runFunction, callFunction,+    callDeferredFunction, atomic,     -    -- * Internal-    updateElement,+    -- * Internal and oddball functions+    updateElement, manifestElement, audioPlay, fromProp,          ) where +import Data.IORef import Data.Maybe (listToMaybe) import Data.Functor+import Data.String (fromString)+import Control.Concurrent.MVar import Control.Event import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.Reader as Reader--import Control.Concurrent.MVar-import Data.IORef--import Data.String (fromString)- import Network.URI+import Text.JSON  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, EventData)@@ -317,7 +316,22 @@ getElementsById window name =     mapM fromAlive =<< Core.getElementsById window name +{-----------------------------------------------------------------------------+    Oddball+------------------------------------------------------------------------------}+audioPlay = updateElement Core.audioPlay +-- 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+ {-----------------------------------------------------------------------------     Layout ------------------------------------------------------------------------------}@@ -336,8 +350,8 @@ -- -- >  <div class="table"> -- >    <div class="table-row">--- >      <div class="table-cell> ... </div>--- >      <div class="table-cell> ... </div>+-- >      <div class="table-cell"> ... </div>+-- >      <div class="table-cell"> ... </div> -- >    </div> -- >    <div class="table-row"> -- >      ...

@@ -6,23 +6,24 @@     new,          -- * Primitive HTML elements-    address, a, anchor, applet, area,+    address, a, anchor, applet, area, audio,     basefont, big, blockquote, body, bold, br, button,-    caption, center, cite, ddef, define, div, dlist,+    canvas, caption, center, cite, code,+    ddef, define, div, dlist,     dterm, emphasize, fieldset, font, form, frame, frameset,     h1, h2, h3, h4, h5, h6, header, hr,     img, image, input, italics,-    keyboard, legend, li, meta, noframes, olist, option,+    keyboard, legend, li, link, map, meta, noframes, olist, option,     p, paragraph, param, pre,     sample, select, small, source, span, strong, sub, sup,-    table, td, textarea, th, thebase, thecode,-    thehtml, thelink, themap, thetitle, tr, tt, ul,+    table, td, textarea, th, thebase,+    thehtml, title_, tr, tt, ul,     underline, variable, video,     ) where  import Control.Monad import Control.Monad.Trans.Reader-import Prelude hiding (span,div)+import Prelude hiding (span,div,map) import Graphics.UI.Threepenny.Core  {-----------------------------------------------------------------------------@@ -63,6 +64,7 @@ anchor              =  tag "a" applet              =  tag "applet" area                = itag "area"+audio               =  tag "audio" basefont            = itag "basefont" big                 =  tag "big" blockquote          =  tag "blockquote"@@ -70,9 +72,11 @@ bold                =  tag "b" br                  = itag "br" button              =  tag "button"+canvas              =  tag "canvas" caption             =  tag "caption" center              =  tag "center" cite                =  tag "cite"+code                =  tag "code" ddef                =  tag "dd" define              =  tag "dfn" div                 =  tag "div"@@ -99,6 +103,8 @@ keyboard            =  tag "kbd" legend              =  tag "legend" li                  =  tag "li"+link                =  tag "link"+map                 =  tag "map" meta                = itag "meta" noframes            =  tag "noframes" olist               =  tag "ol"@@ -119,12 +125,9 @@ textarea            =  tag "textarea" th                  =  tag "th" thebase             = itag "base"-thecode             =  tag "code" thehtml             =  tag "html"-thelink             =  tag "link"-themap              =  tag "map" span                =  tag "span"-thetitle            =  tag "title"+title_              =  tag "title" tr                  =  tag "tr" tt                  =  tag "tt" ul                  =  tag "ul"

@@ -3,7 +3,8 @@     -- | Common DOM events, for convenience.          -- * Documentation-    click, hover, blur, leave,+    click, mousemove, hover, blur, leave,+    keyup, keydown,     ) where  import Graphics.UI.Threepenny.Core@@ -18,6 +19,18 @@ 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.+--+-- 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)+ -- | Mouse leaving an element. leave :: Element -> Event () leave = silence . domEvent "mouseleave"@@ -25,3 +38,16 @@ -- | Element loses focus. blur :: Element -> Event () blur = silence . domEvent "blur"+++type KeyCode = Int++-- | Key pressed while element has focus.+keydown :: Element -> Event KeyCode+keydown = fmap read1  . domEvent "keydown"++-- | Key released while element has focus.+keyup :: Element -> Event KeyCode+keyup   = fmap read1 . domEvent "keyup"++read1 (EventData (Just s:_)) = read s

@@ -26,6 +26,7 @@   -- $settingattributes   ,setStyle   ,setAttr+  ,setProp   ,setText   ,setHtml   ,setTitle@@ -44,6 +45,7 @@   ,getElementsByTagName   ,getElementsById   ,getWindow+  ,getProp   ,getValue   ,getValuesList   ,readValue@@ -54,11 +56,16 @@   -- * Utilities   ,debug   ,clear-  ,callFunction-  ,runFunction   ,callDeferredFunction   ,atomic++  -- * JavaScript FFI+  ,ToJS, FFI, ffi, JSFunction+  ,runFunction, callFunction   +  -- * Oddball+  ,audioPlay+     -- * Types   ,Window   ,Element@@ -260,10 +267,10 @@   writeJson instructions  -- Write JSON to output.-writeJson :: (MonadSnap m, Data a) => a -> m ()+writeJson :: (MonadSnap m, JSON a) => a -> m () writeJson json = do     modifyResponse $ setContentType "application/json"-    (writeString . encodeJSON) json+    (writeString . (\x -> showJSValue x "") . showJSON) json  -- Write a string to output. writeString :: (MonadSnap m) => String -> m ()@@ -305,19 +312,21 @@ readInput :: (MonadSnap f,Read a) => ByteString -> f (Maybe a) readInput = fmap (>>= readMay) . getInput ------------------------------------------------------------------------------------ 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. +{-----------------------------------------------------------------------------+    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 = forever $ handleEvent window@@ -358,13 +367,14 @@     _ <- register (sEvent 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. +{-----------------------------------------------------------------------------+    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).@@ -379,6 +389,14 @@         -> 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.@@ -407,12 +425,12 @@ delete e@(Element el session)  = run session $ Delete el  ------------------------------------------------------------------------------------ Manipulating tree structure---+{-----------------------------------------------------------------------------+    Manipulating tree structure+------------------------------------------------------------------------------} -- $treestructure--- --- Functions for creating, deleting, moving, appending, prepending, DOM nodes.+--+--  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@@ -434,10 +452,17 @@     --       Implement transfer of elements across browser windows     run session $ Append parent child ------------------------------------------------------------------------------------- Querying the DOM---++{-----------------------------------------------------------------------------+    Oddball+------------------------------------------------------------------------------}+-- | Invoke the JavaScript expression @audioElement.play();@.+audioPlay :: Element -> IO ()+audioPlay (Element el session) = runFunction session $ ffi "%1.play();" el++{-----------------------------------------------------------------------------+    Querying the DOM+------------------------------------------------------------------------------} -- $querying --  -- The DOM can be searched for elements of a given name, and nodes can@@ -475,6 +500,14 @@       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@@ -551,10 +584,9 @@ getRequestCookies :: Window -> IO [(String,String)] getRequestCookies = return . snd . sStartInfo ------------------------------------------------------------------------------------- Utilities-+{-----------------------------------------------------------------------------+    Utilities+------------------------------------------------------------------------------} -- | Send a debug message to the client. The behaviour of the client --   is unspecified. debug@@ -567,26 +599,23 @@ clear :: Window -> IO () clear window = run window $ Clear () --- | Call the given function and wait for results. Blocks.-callFunction-  :: Window             -- ^ Browser window-  -> String             -- ^ The function name.-  -> [String]           -- ^ Parameters.-  -> IO [Maybe String]  -- ^ Return tuple.-callFunction window func params =-  call window (CallFunction (func,params)) $ \signal ->-    case signal of-      FunctionCallValues vs -> return (Just vs)-      _                     -> return Nothing+-- | 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 --- | Call the given function and carry on. Doesn't block.-runFunction-  :: Window            -- ^ Browser window-  -> String            -- ^ The function name.-  -> [String]          -- ^ Parameters.-  -> IO ()-runFunction window func params =-  run window $ CallFunction (func,params)+-- | Run the given JavaScript function and wait for results. Blocks.+--+-- The client window uses JavaScript's @eval()@ function to run the code.+callFunction :: Window -> JSFunction a -> IO a+callFunction window (JSFunction code marshal) = +    call window (CallJSFunction . unJSCode $ code) $ \signal ->+        case signal of+            FunctionResult v -> case marshal window v of+                Ok    a -> return $ Just a+                Error _ -> return Nothing+            _ -> return Nothing  -- | Call the given function with the given continuation. Doesn't block. callDeferredFunction

@@ -1,16 +1,9 @@-{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}---- | All Threepenny's types. See "Graphics.UI.Threepenny.Types" for only public---   types. Non-public types can be manipulated at your own risk, if you---   know what you're doing and you want to add something that the---   library doesn't do.+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} -module Graphics.UI.Threepenny.Internal.Types-  where+module Graphics.UI.Threepenny.Internal.Types where -import Prelude              hiding ((++),init)+import Prelude              hiding (init)  import Control.Applicative import Control.Concurrent@@ -23,8 +16,9 @@ import Network.URI import Text.JSON.Generic ------------------------------------------------------------------------------------ Public types+{-----------------------------------------------------------------------------+    Public types+------------------------------------------------------------------------------}  -- | Reference to an element in the DOM of the client window. data Element = Element@@ -87,9 +81,18 @@ -- | Data from an event. At the moment it is empty. data EventData = EventData [Maybe String] ------------------------------------------------------------------------------------ Internal types+-- | Record for configuring the Threepenny GUI server.+data Config = Config+  { tpPort       :: Int               -- ^ Port number.+  , tpCustomHTML :: Maybe FilePath    -- ^ Custom HTML file to replace the default one.+  , tpStatic     :: FilePath          -- ^ Directory that is served under @/static@.+  } ++{-----------------------------------------------------------------------------+    Communication between client and server+------------------------------------------------------------------------------}+ -- | An instruction that is sent to the client as JSON. data Instruction   = Debug String@@ -109,12 +112,17 @@   | GetValues [ElementId]   | SetTitle String   | GetLocation ()-  | CallFunction (String,[String])+  | RunJSFunction String+  | CallJSFunction String   | CallDeferredFunction (Closure,String,[String])   | EmptyEl ElementId   | Delete ElementId   deriving (Typeable,Data,Show) +instance JSON Instruction where+    readJSON _ = error "JSON.Instruction.readJSON: No method implemented."+    showJSON x = toJSON x + -- | A signal (mostly events) that are sent from the client to the server. data Signal   = Init ()@@ -124,6 +132,7 @@   | Values [String]   | Location String   | FunctionCallValues [Maybe String]+  | FunctionResult JSValue   deriving (Show)  instance JSON Signal where@@ -141,7 +150,9 @@         values = Values <$> valFromObj "Values" obj         fcallvalues = do           FunctionCallValues <$> (valFromObj "FunctionCallValues" obj >>= mapM nullable)-    init <|> elements <|> event <|> value <|> values <|> location <|> fcallvalues+        fresult = FunctionResult <$> valFromObj "FunctionResult" obj+    init <|> elements <|> event <|> value <|> values <|> location+         <|> fcallvalues <|> fresult  -- | Read a JSValue that may be null. nullable :: JSON a => JSValue -> Result (Maybe a)@@ -151,11 +162,99 @@ -- | An opaque reference to a closure that the event manager uses to --   trigger events signalled by the client. data Closure = Closure (String,String)-  deriving (Typeable,Data,Show)+    deriving (Typeable,Data,Show) --- | Record for configuring the Threepenny GUI server.-data Config = Config-  { tpPort       :: Int               -- ^ Port number.-  , tpCustomHTML :: Maybe FilePath    -- ^ Custom HTML file to replace the default one.-  , tpStatic     :: FilePath          -- ^ Directory that is served under @/static@.-  }+{-----------------------------------------------------------------------------+    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+

@@ -45,9 +45,9 @@ -- | Focus an element. setFocus :: Element -> IO () setFocus = updateElement $ \(Core.Element el window) ->-    runFunction window "jquery_setFocus" [encode el]+    runFunction window (ffi "$(%1).focus()" el)  -- | Scroll to the bottom of an element. scrollToBottom :: Element -> IO () scrollToBottom = updateElement $ \(Core.Element area window) ->-    runFunction window "jquery_scrollToBottom" [encode area]+    runFunction window (ffi "jquery_scrollToBottom(%1)" area)

@@ -0,0 +1,76 @@+{-# LANGUAGE RecordWildCards #-}++module Graphics.UI.Threepenny.Timer (+    -- * Synopsis+    -- | Implementation of a simple timer which runs on the server-side.+    +    -- * Documentation+    Timer, timer,+    interval, running, tick, start, stop,+    ) where+++import Control.Monad (when, forever, void)+import Control.Event+import Control.Concurrent+import Control.Concurrent.STM++import Graphics.UI.Threepenny.Core+++data Timer = Timer+    { tRunning  :: TVar Bool+    , tInterval :: TVar Int      -- in ms+    , tTick     :: Event ()+    }++-- | Create a new timer+timer :: IO Timer+timer = do+    tRunning      <- newTVarIO False+    tInterval     <- newTVarIO 1000+    (tTick, fire) <- newEvent+    +    forkIO $ forever $ do+        wait <- atomically $ do+            b <- readTVar tRunning+            when (not b) retry+            readTVar tInterval+        threadDelay (wait * 1000)+        fire ()+        +    return $ Timer {..}++tick = tTick++-- | Timer interval in milliseconds.+interval :: Attr Timer Int+interval = fromTVar tInterval++-- | Whether the timer is running or not.+running :: Attr Timer Bool+running = fromTVar tRunning++-- | Start the timer.+start :: Timer -> IO ()+start = set' running True++-- | Stop the timer.+stop :: Timer -> IO ()+stop = set' running False++fromTVar :: (x -> TVar a) -> Attr x a+fromTVar f = mkReadWriteAttr+    (atomically . readTVar . f)+    (\i x -> atomically $ writeTVar (f x) i)+++{-----------------------------------------------------------------------------+    Small test+------------------------------------------------------------------------------}+testTimer = do+    t <- timer+    void $ register (tick t) $ const $ putStr "Hello"+    return t+        # set interval 1000+        # set running True

@@ -59,27 +59,7 @@   window.do_logging = function(x){     $.cookie('tp_log',x.toString());   };-  -  window.jquery_animate = function(el_id,props,duration,easing,complete){-    var el = elidToElement(JSON.parse(el_id));-    $(el).animate(JSON.parse(props),-                  duration * 1,-                  easing * 1,-                  complete);-  }--  window.jquery_scrollToBottom = function(el_id,cont){-    var el = elidToElement(JSON.parse(el_id));-    $(el).scrollTop(el.scrollHeight);-    cont();-  };--  window.jquery_setFocus = function(el_id,cont){-    var el = elidToElement(JSON.parse(el_id));-    $(el).focus();-    cont();-  };-  +       function waitForEvents(){     console_log("Polling… (%d signals so far)",signal_count);     var data = { token: sessionToken };@@ -126,6 +106,7 @@     console_log("Event: %s",JSON.stringify(event));     for(var key in event){       switch(key){+                       case "EmptyEl": {         var id = event.EmptyEl;         var el = elidToElement(id);@@ -153,20 +134,16 @@         continuation();         break;       }-      case "CallFunction": {-        var call = event.CallFunction;-        var theFunction = eval(call[0]);-        var params = call[1];-        theFunction.apply(window, params.concat(function(){-          var args = Array.prototype.slice.call(arguments,0);-          signal({-            FunctionCallValues: args-          },function(){-            continuation();-          });-        }));+      case "RunJSFunction": {+        eval(event.RunJSFunction);+        continuation();         break;       }+      case "CallJSFunction": {+        var result = eval(event.CallJSFunction);+        signal({FunctionResult : result}, continuation);+        break;+      }       case "Delete": {         event_delete(event);         continuation();@@ -231,11 +208,11 @@         break;       }       case "SetAttr": {-        var set = event.SetAttr;-        var id = set[0];-        var key = set[1];+        var set   = event.SetAttr;+        var id    = set[0];+        var key   = set[1];         var value = set[2];-        var el = elidToElement(id);+        var el    = elidToElement(id);         $(el).attr(key,value);         continuation();         break;@@ -297,8 +274,8 @@         break;       }       case "Bind": {-        var bind = event.Bind;-        var eventType = bind[0];+        var bind        = event.Bind;+        var eventType   = bind[0];         var handlerGuid = bind[2];         var el = elidToElement(bind[1]);         console_log('event type: ' + eventType);@@ -329,6 +306,24 @@             });             return true;           });+        } else if(eventType.match('mousemove')) {+          $(el).bind(eventType,function(e){+            signal({+              Event: handlerGuid.concat([[e.pageX.toString(), e.pageY.toString()]])+            },function(){+              // no action+            });+            return true;+          });+        } else if(eventType.match('keydown|keyup')) {+          $(el).bind(eventType,function(e){+            signal({+              Event: handlerGuid.concat([[e.keyCode.toString()]])+            },function(){+              // no action+            });+            return true;+          });         } else {           $(el).bind(eventType,function(e){             signal({@@ -430,6 +425,37 @@     if (tp_enable_log) {       window.console.log.apply(window.console,arguments);     }+  };+++  ////////////////////////////////////////////////////////////////////////////////+  // Additional functions+  +  window.jquery_animate = function(el_id,props,duration,easing,complete){+    var el = elidToElement(JSON.parse(el_id));+    $(el).animate(JSON.parse(props),+                  duration * 1,+                  easing * 1,+                  complete);+  }++  window.jquery_scrollToBottom = function(el){+    $(el).scrollTop(el.scrollHeight);+  };++  // see http://stackoverflow.com/a/9722502/403805+  CanvasRenderingContext2D.prototype.clear = +    CanvasRenderingContext2D.prototype.clear || function (preserveTransform) {+      if (preserveTransform) {+        this.save();+        this.setTransform(1, 0, 0, 1, 0, 0);+      }++      this.clearRect(0, 0, this.canvas.width, this.canvas.height);++      if (preserveTransform) {+        this.restore();+      }              };  })();

@@ -1,5 +1,5 @@ Name:                threepenny-gui-Version:             0.1.0.1+Version:             0.2.0.0 Synopsis:            Small GUI framework that uses the web browser as a display. Description:     Threepenny-GUI is a small GUI framework that uses the web browser as a display.@@ -14,6 +14,16 @@     Stability forecast: This is an experimental release! Send us your feedback!     Basic functionality should work.     Significant API changes are likely in future versions.+    .+    NOTE: This library contains examples, but they are not built by default.+    To build and install the example, use the @buildExamples@ flag like this+    .+    @cabal install reactive-banana-threepenny -fbuildExamples@+    .+    Changelog:+    .+    * 0.2.0.0 - Snapshot release. First stab at easy JavaScript FFI.+    * 0.1.0.0 - Initial release.  License:             BSD3 License-file:        LICENSE@@ -32,8 +42,10 @@                     ,src/Graphics/UI/*.html                     ,src/Graphics/UI/*.css                     ,wwwroot/css/*.css+                    ,wwwroot/css/*.png                     ,wwwroot/*.html                     ,wwwroot/*.txt+                    ,wwwroot/*.wav   flag buildExamples@@ -52,10 +64,12 @@                     ,Graphics.UI.Threepenny                     ,Graphics.UI.Threepenny.Attributes                     ,Graphics.UI.Threepenny.Core+                    ,Graphics.UI.Threepenny.Canvas                     ,Graphics.UI.Threepenny.DragNDrop                     ,Graphics.UI.Threepenny.Elements                     ,Graphics.UI.Threepenny.Events                     ,Graphics.UI.Threepenny.JQuery+                    ,Graphics.UI.Threepenny.Timer   Other-modules:                      Control.Concurrent.Chan.Extra                     ,Control.Monad.Extra@@ -81,6 +95,7 @@                     ,filepath                     ,data-default                     ,transformers+                    ,stm                      Executable threepenny-examples-bartab     if flag(buildExamples)@@ -118,6 +133,17 @@     other-modules:     Paths_threepenny_gui, Paths     hs-source-dirs:    src +Executable threepenny-examples-drummachine+    if flag(buildExamples)+        cpp-options:       -DCABAL+        build-depends:     base                      >= 4     && < 5+                          ,threepenny-gui+                          ,filepath+    else+        buildable: False+    main-is:           DrumMachine.hs+    other-modules:     Paths_threepenny_gui, Paths+    hs-source-dirs:    src  Executable threepenny-examples-missing-dollars     if flag(buildExamples)

binary file changed (absent → 4690 bytes)

binary file changed (absent → 162 bytes)

binary file changed (absent → 628939 bytes)

binary file changed (absent → 28556 bytes)

binary file changed (absent → 31622 bytes)

binary file changed (absent → 76332 bytes)