diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,28 @@
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of Heinrich Apfelmus nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/src/BarTab.hs b/src/BarTab.hs
new file mode 100644
--- /dev/null
+++ b/src/BarTab.hs
@@ -0,0 +1,87 @@
+{-# 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 Config
+ { tpPort = 10000
+ , tpCustomHTML = Nothing
+ , tpStatic = 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
new file mode 100644
--- /dev/null
+++ b/src/Buttons.hs
@@ -0,0 +1,86 @@
+{-# 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 Config
+ { tpPort = 10000
+ , tpCustomHTML = Nothing
+ , tpStatic = 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
+ threadDelay $ 1000 * 1000 * 1
+ element button1 # set text (button1Title ++ " [pressed]")
+ 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 button1 # set text (button1Title ++ " [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
new file mode 100644
--- /dev/null
+++ b/src/Chat.hs
@@ -0,0 +1,108 @@
+{-# 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 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 Config
+ { tpPort = 10000
+ , tpCustomHTML = Just "chat.html"
+ , tpStatic = static
+ } $ setup messages
+
+type Message = (UTCTime, String, String)
+
+setup :: Chan Message -> Window -> IO ()
+setup globalMsgs w = do
+ msgs <- Chan.dupChan globalMsgs
+
+ return w # set title "Chat"
+
+ (nick, nickname) <- mkNickname
+ messageArea <- mkMessageArea msgs nick
+
+ getBody w #+
+ [ UI.div #. "header" #+ [string "Threepenny Chat"]
+ , UI.div #. "gradient"
+ , viewSource
+ , element nickname
+ , element messageArea
+ ]
+
+ void $ forkIO $ receiveMessages w msgs messageArea
+
+-- io $ catch (runTP session handleEvents)
+-- (\e -> do killThread messageReceiver
+-- throw (e :: SomeException))
+
+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 -> Element -> IO Element
+mkMessageArea msgs nickname = do
+ input <- UI.textarea #. "send-textarea"
+
+ on UI.sendValue input $ (. trim) $ \content -> do
+ when (not (null content)) $ do
+ now <- getCurrentTime
+ nick <- trim <$> get value nickname
+ 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 (Element, Element)
+mkNickname = do
+ i <- UI.input #. "name-input"
+ el <- UI.div #. "name-area" #+
+ [ UI.span #. "name-label" #+ [string "Your name "]
+ , element i
+ ]
+ UI.setFocus i
+ return (i,el)
+
+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/Control/Concurrent/Chan/Extra.hs b/src/Control/Concurrent/Chan/Extra.hs
new file mode 100644
--- /dev/null
+++ b/src/Control/Concurrent/Chan/Extra.hs
@@ -0,0 +1,22 @@
+-- | Extra utilities for chans.
+
+module Control.Concurrent.Chan.Extra
+ (readAvailableChan)
+ where
+
+import Control.Concurrent.Chan
+
+readAvailableChan :: Chan a -> IO [a]
+readAvailableChan chan = do
+ v <- readChan chan
+ vs <- rest
+ return (v:vs)
+
+ where
+ rest = do
+ empty <- isEmptyChan chan
+ if empty
+ then return []
+ else do v <- readChan chan
+ vs <- rest
+ return (v:vs)
diff --git a/src/Control/Concurrent/Delay.hs b/src/Control/Concurrent/Delay.hs
new file mode 100644
--- /dev/null
+++ b/src/Control/Concurrent/Delay.hs
@@ -0,0 +1,17 @@
+-- | Delay a thread for n seconds or minutes.
+
+module Control.Concurrent.Delay
+ (delaySeconds
+ ,delayMinutes)
+ where
+
+import Control.Concurrent
+
+-- | Delay the current thread for at least n seconds.
+delaySeconds :: Integer -> IO ()
+delaySeconds 0 = return ()
+delaySeconds n = do threadDelay (1000 * 1000); delaySeconds (n-1)
+
+-- | Delay the current thread for at least n minutes.
+delayMinutes :: Integer -> IO ()
+delayMinutes = delaySeconds . (*60)
diff --git a/src/Control/Event.hs b/src/Control/Event.hs
new file mode 100644
--- /dev/null
+++ b/src/Control/Event.hs
@@ -0,0 +1,111 @@
+module Control.Event (
+ -- * Synopsis
+ -- | Event-driven programming in the imperative style.
+
+ -- * Documentation
+ Handler, Event(..),
+ mapIO, filterIO, filterJust,
+ newEvent, newEventsTagged
+ ) where
+
+
+import Data.IORef
+import qualified Data.Unique -- ordinary uniques here, because they are Ord
+
+import qualified Data.Map as Map
+
+type Map = Map.Map
+
+{-----------------------------------------------------------------------------
+ Types
+------------------------------------------------------------------------------}
+-- | An /event handler/ is a function that takes an
+-- /event value/ and performs some computation.
+type Handler a = a -> IO ()
+
+
+-- | An /event/ is a facility for registering
+-- event handlers. These will be called whenever the event occurs.
+--
+-- When registering an event handler, you will also be given an action
+-- that unregisters this handler again.
+--
+-- > do unregisterMyHandler <- register event myHandler
+--
+newtype Event a = Event { register :: Handler a -> IO (IO ()) }
+
+{-----------------------------------------------------------------------------
+ Combinators
+------------------------------------------------------------------------------}
+instance Functor Event where
+ fmap f = mapIO (return . f)
+
+-- | Map the event value with an 'IO' action.
+mapIO :: (a -> IO b) -> Event a -> Event b
+mapIO f e = Event $ \h -> register e $ \x -> f x >>= h
+
+-- | Filter event values that don't return 'True'.
+filterIO :: (a -> IO Bool) -> Event a -> Event a
+filterIO f e = Event $ \h ->
+ register e $ \x -> f x >>= \b -> if b then h x else return ()
+
+-- | Keep only those event values that are of the form 'Just'.
+filterJust :: Event (Maybe a) -> Event a
+filterJust e = Event $ \g -> register e (maybe (return ()) g)
+
+
+{-----------------------------------------------------------------------------
+ Construction
+------------------------------------------------------------------------------}
+-- | Build a facility to register and unregister event handlers.
+-- Also yields a function that takes an event handler and runs all the registered
+-- handlers.
+--
+-- Example:
+--
+-- > do
+-- > (event, fire) <- newEvent
+-- > register event (putStrLn)
+-- > fire "Hello!"
+newEvent :: IO (Event a, a -> IO ())
+newEvent = do
+ handlers <- newIORef Map.empty
+ let register handler = do
+ key <- Data.Unique.newUnique
+ atomicModifyIORef_ handlers $ Map.insert key handler
+ return $ atomicModifyIORef_ handlers $ Map.delete key
+ runHandlers a =
+ mapM_ ($ a) . map snd . Map.toList =<< readIORef handlers
+ return (Event register, runHandlers)
+
+-- | Build several 'Event's from case analysis on a tag.
+-- Generalization of 'newEvent'.
+newEventsTagged :: Ord tag => IO (tag -> Event a, (tag, a) -> IO ())
+newEventsTagged = do
+ handlersRef <- newIORef Map.empty -- :: Map key (Map Unique (Handler a))
+
+ let register tag handler = do
+ -- new identifier for this handler
+ uid <- Data.Unique.newUnique
+ -- add handler to map at key
+ atomicModifyIORef_ handlersRef $
+ Map.alter (Just . Map.insert uid handler . maybe Map.empty id) tag
+ -- remove handler from map at key
+ return $ atomicModifyIORef_ handlersRef $
+ Map.adjust (Map.delete uid) tag
+
+ let runHandlers (tag,a) = do
+ handlers <- readIORef handlersRef
+ case Map.lookup tag handlers of
+ Just hs -> mapM_ ($ a) (Map.elems hs)
+ Nothing -> return ()
+
+ return (\tag -> Event (register tag), runHandlers)
+
+{-----------------------------------------------------------------------------
+ Utilities
+------------------------------------------------------------------------------}
+atomicModifyIORef_ ref f = atomicModifyIORef ref $ \x -> (f x, ())
+
+
+
diff --git a/src/Control/Monad/Extra.hs b/src/Control/Monad/Extra.hs
new file mode 100644
--- /dev/null
+++ b/src/Control/Monad/Extra.hs
@@ -0,0 +1,30 @@
+-- | Extra utilities for monads.
+
+module Control.Monad.Extra where
+
+import Data.Maybe
+
+-- | Ignore the given action's return.
+ig :: (Monad m) => m a -> m ()
+ig m = m >> return ()
+
+-- | A non-operator version of (=<<).
+bind :: (Monad m) => (a -> m b) -> m a -> m b
+bind = flip (>>=)
+
+-- | When the value is Just, run the action.
+whenJust :: Monad m => Maybe a -> (a -> m ()) -> m ()
+whenJust (Just a) m = m a
+whenJust Nothing _ = return ()
+
+-- | Wrap up a functor in a Maybe.
+just :: Functor m => m a -> m (Maybe a)
+just = fmap Just
+
+-- | Flip mapMaybe.
+forMaybe :: [a] -> (a -> Maybe b) -> [b]
+forMaybe = flip mapMaybe
+
+-- | Monadic version of maybe.
+maybeM :: (Monad m) => a -> (a1 -> m a) -> Maybe a1 -> m a
+maybeM nil cons a = maybe (return nil) cons a
diff --git a/src/Control/Monad/IO.hs b/src/Control/Monad/IO.hs
new file mode 100644
--- /dev/null
+++ b/src/Control/Monad/IO.hs
@@ -0,0 +1,8 @@
+{-# OPTIONS -Wall #-}
+
+module Control.Monad.IO where
+
+import Control.Monad.Trans
+
+io :: MonadIO m => IO a -> m a
+io = liftIO
diff --git a/src/DragNDropExample.hs b/src/DragNDropExample.hs
new file mode 100644
--- /dev/null
+++ b/src/DragNDropExample.hs
@@ -0,0 +1,73 @@
+{-# 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 Config
+ { tpPort = 10000
+ , tpCustomHTML = Nothing
+ , tpStatic = 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/Graphics/UI/Threepenny.hs b/src/Graphics/UI/Threepenny.hs
new file mode 100644
--- /dev/null
+++ b/src/Graphics/UI/Threepenny.hs
@@ -0,0 +1,15 @@
+module Graphics.UI.Threepenny (
+ module Graphics.UI.Threepenny.Attributes,
+ module Graphics.UI.Threepenny.Core,
+ module Graphics.UI.Threepenny.DragNDrop,
+ module Graphics.UI.Threepenny.Elements,
+ module Graphics.UI.Threepenny.Events,
+ module Graphics.UI.Threepenny.JQuery,
+ ) where
+
+import Graphics.UI.Threepenny.Attributes
+import Graphics.UI.Threepenny.Core
+import Graphics.UI.Threepenny.DragNDrop
+import Graphics.UI.Threepenny.Elements
+import Graphics.UI.Threepenny.Events
+import Graphics.UI.Threepenny.JQuery
diff --git a/src/Graphics/UI/Threepenny/Attributes.hs b/src/Graphics/UI/Threepenny/Attributes.hs
new file mode 100644
--- /dev/null
+++ b/src/Graphics/UI/Threepenny/Attributes.hs
@@ -0,0 +1,107 @@
+module Graphics.UI.Threepenny.Attributes (
+ -- * Synopsis
+ -- | Element Attributes, for convenience.
+
+ -- * Documentation
+ action, align, alink, alt, altcode, archive,
+ background, base, bgcolor, border, bordercolor,
+ 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,
+ name, nohref, noresize, noshade, nowrap,
+ rel, rev, rows, rowspan, rules,
+ scrolling, selected, shape, size, src, start,
+ target, text_, type_, usemap, valign, version, vlink, vspace, width,
+ ) where
+
+
+import Graphics.UI.Threepenny.Core
+
+{-----------------------------------------------------------------------------
+ Attributes
+------------------------------------------------------------------------------}
+strAttr :: String -> WriteAttr Element String
+strAttr name = mkWriteAttr (set' (attr name))
+
+intAttr :: String -> WriteAttr Element Int
+intAttr name = mkWriteAttr (set' (attr name) . show)
+
+emptyAttr :: String -> WriteAttr Element Bool
+emptyAttr name = mkWriteAttr (set' (attr name) . f)
+ 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"
+alt = strAttr "alt"
+altcode = strAttr "altcode"
+archive = strAttr "archive"
+background = strAttr "background"
+base = strAttr "base"
+bgcolor = strAttr "bgcolor"
+border = intAttr "border"
+bordercolor = strAttr "bordercolor"
+cellpadding = intAttr "cellpadding"
+cellspacing = intAttr "cellspacing"
+checked = emptyAttr "checked"
+clear_ = strAttr "clear"
+code = strAttr "code"
+codebase = strAttr "codebase"
+color = strAttr "color"
+cols = strAttr "cols"
+colspan = intAttr "colspan"
+compact = emptyAttr "compact"
+content = strAttr "content"
+coords = strAttr "coords"
+enctype = strAttr "enctype"
+face = strAttr "face"
+frameborder = intAttr "frameborder"
+height = intAttr "height"
+href = strAttr "href"
+hspace = intAttr "hspace"
+httpequiv = strAttr "http-equiv"
+id_ = strAttr "id"
+ismap = emptyAttr "ismap"
+lang = strAttr "lang"
+link = strAttr "link"
+marginheight = intAttr "marginheight"
+marginwidth = intAttr "marginwidth"
+maxlength = intAttr "maxlength"
+method = strAttr "method"
+multiple = emptyAttr "multiple"
+name = strAttr "name"
+nohref = emptyAttr "nohref"
+noresize = emptyAttr "noresize"
+noshade = emptyAttr "noshade"
+nowrap = emptyAttr "nowrap"
+rel = strAttr "rel"
+rev = strAttr "rev"
+rows = strAttr "rows"
+rowspan = intAttr "rowspan"
+rules = strAttr "rules"
+scrolling = strAttr "scrolling"
+selected = emptyAttr "selected"
+shape = strAttr "shape"
+size = strAttr "size"
+src = strAttr "src"
+start = intAttr "start"
+target = strAttr "target"
+text_ = strAttr "text"
+class_ = strAttr "class"
+type_ = strAttr "type"
+title = strAttr "title"
+usemap = strAttr "usemap"
+valign = strAttr "valign"
+version = strAttr "version"
+vlink = strAttr "vlink"
+vspace = intAttr "vspace"
+width = strAttr "width"
diff --git a/src/Graphics/UI/Threepenny/Core.hs b/src/Graphics/UI/Threepenny/Core.hs
new file mode 100644
--- /dev/null
+++ b/src/Graphics/UI/Threepenny/Core.hs
@@ -0,0 +1,472 @@
+module Graphics.UI.Threepenny.Core (
+ -- * Guide
+ -- $guide
+
+ -- * Server
+ -- $server
+ Config(..), startGUI,
+ loadFile, loadDirectory,
+
+ -- * Browser Window
+ Window, title, cookies, getRequestLocation,
+
+ -- * DOM elements
+ -- | Create and manipulate DOM elements.
+ Element, mkElement, getWindow, delete, (#+), string,
+ getHead, getBody,
+ children, text, html, attr, style, value,
+ getValuesList,
+ getElementsByTagName, getElementByTagName, getElementsById, getElementById,
+
+ -- * Layout
+ -- | Combinators for quickly creating layouts.
+ -- They can be adjusted with CSS later on.
+ grid, row, column,
+
+ -- * Events
+ -- | For a list of predefined events, see "Graphics.UI.Threepenny.Events".
+ EventData(..), domEvent, on,
+ module Control.Event,
+
+ -- * Attributes
+ -- | For a list of predefined attributes, see "Graphics.UI.Threepenny.Attributes".
+ (#), (#.), element,
+ Attr, WriteAttr, ReadAttr, ReadWriteAttr(..),
+ set, get, mkReadWriteAttr, mkWriteAttr, mkReadAttr,
+
+ -- * Utilities
+ -- | A few raw JavaScript utilities.
+ debug, clear,
+ callFunction, runFunction, callDeferredFunction,
+ atomic,
+
+ -- * Internal
+ updateElement,
+
+ ) where
+
+import Data.Maybe (listToMaybe)
+import Data.Functor
+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 qualified Graphics.UI.Threepenny.Internal.Core as Core
+import Graphics.UI.Threepenny.Internal.Core
+ (getRequestLocation,
+ debug, clear, callFunction, runFunction, callDeferredFunction, atomic, )
+import qualified Graphics.UI.Threepenny.Internal.Types as Core
+import Graphics.UI.Threepenny.Internal.Types (Window, Config, EventData)
+
+{-----------------------------------------------------------------------------
+ Guide
+------------------------------------------------------------------------------}
+{- $guide
+
+Threepenny runs a small web server that displays the user interface
+as a web page to any browser that connects to it.
+To start the web server, use the 'startGUI' function.
+
+Creating of DOM elements is easy,
+the '(#+)' combinator allows a style similar to HTML combinator libraries.
+
+Existing DOM elements can be accessed much in the same way they are
+accessed from JavaScript; they can be searched, updated, moved and
+inspected. Events can be bound to DOM elements and handled.
+
+
+Applications written in Threepenny are multithreaded. Each client (user)
+has a separate thread which runs with no awareness of the asynchronous
+protocol below. Each session should only be accessed from one
+thread. There is not yet any clever architecture for accessing the
+(single threaded) web browser from multi-threaded Haskell. That's
+my recommendation. You can choose to ignore it, but don't blame me
+when you run an element search and you get a click event as a
+result.
+
+This project was originally called Ji.
+
+-}
+
+
+{-----------------------------------------------------------------------------
+ Server
+------------------------------------------------------------------------------}
+{- $server
+
+To display the user interface, you have to start a server using 'startGUI'.
+Then, visit the URL in your browser
+(assuming that you have set the port number to @tpPort=10000@
+in the server configuration).
+
+-}
+
+-- | Start server for GUI sessions.
+startGUI
+ :: Config -- ^ Server configuration.
+ -> (Window -> IO ()) -- ^ Action to run whenever a client browser connects.
+ -> IO ()
+startGUI config handler =
+ Core.serve config $ \w -> handler w >> Core.handleEvents w
+
+
+-- | Make a local file available as a relative URI.
+loadFile
+ :: Window -- ^ Browser window
+ -> String -- ^ MIME type
+ -> FilePath -- ^ Local path to the file
+ -> IO String -- ^ Generated URI
+loadFile w mime path = Core.loadFile w (fromString mime) path
+
+-- | Make a local directory available as a relative URI.
+loadDirectory :: Window -> FilePath -> IO String
+loadDirectory = Core.loadDirectory
+
+{-----------------------------------------------------------------------------
+ Browser window
+------------------------------------------------------------------------------}
+-- | Title of the client window.
+title :: WriteAttr Window String
+title = mkWriteAttr Core.setTitle
+
+-- | Cookies on the client.
+cookies :: ReadAttr Window [(String,String)]
+cookies = mkReadAttr Core.getRequestCookies
+
+{-----------------------------------------------------------------------------
+ Elements
+------------------------------------------------------------------------------}
+type Value = String
+
+-- | Reference to an element in the DOM of the client window.
+newtype Element = Element (MVar Elem)
+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 = Element <$> 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 me) = do
+ e1 <- takeMVar me
+ e2 <- case e1 of
+ Alive e -> return e
+ Limbo v create -> do { e2 <- create w; Core.setAttr "value" v e2; return e2 }
+ putMVar me $ Alive e2
+ return e2
+
+-- 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
+
+-- | Make a new DOM element.
+mkElement
+ :: String -- ^ Tag name
+ -> IO Element
+mkElement tag = Element <$> newMVar (Limbo "" $ \w -> Core.newElement w tag)
+
+-- | Retreive 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
+
+-- | Delete the given element.
+delete :: Element -> IO ()
+delete = updateElement (Core.delete)
+
+-- | Append DOM elements as children to a given element.
+(#+) :: IO Element -> [IO Element] -> IO Element
+(#+) mx mys = do
+ x <- mx
+ ys <- sequence mys
+ mapM_ (appendTo x) 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
+
+-- | Child elements of a given element as a HTML string.
+html :: WriteAttr Element String
+html = mkWriteAttr (updateElement . Core.setHtml)
+
+-- | HTML attributes of an element.
+attr :: String -> WriteAttr Element String
+attr name = mkWriteAttr (updateElement . Core.setAttr name)
+
+-- | Set CSS style of an Element
+style :: WriteAttr Element [(String,String)]
+style = mkWriteAttr (updateElement . Core.setStyle)
+
+-- | 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 values from inputs. Blocks. This is faster than many 'getValue' invocations.
+getValuesList
+ :: [Element] -- ^ A list of elements to get the values of.
+ -> IO [String] -- ^ The list of plain text values.
+getValuesList = mapM (get value)
+ -- TODO: improve this to use Core.getValuesList
+
+-- | Text content of an element.
+text :: WriteAttr Element String
+text = mkWriteAttr (updateElement . Core.setText)
+
+-- | Make a @span@ element with a given text content.
+string :: String -> IO Element
+string s = mkElement "span" # set text s
+
+
+-- | Get the head of the page.
+getHead :: Window -> IO Element
+getHead = fromAlive <=< Core.getHead
+
+-- | 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
+
+-- | 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
+
+-- | 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
+
+
+{-----------------------------------------------------------------------------
+ Layout
+------------------------------------------------------------------------------}
+-- | Align given elements in a row. Special case of 'grid'.
+row :: [IO Element] -> IO Element
+row xs = grid [xs]
+
+-- | Align given elements in a column. Special case of 'grid'.
+column :: [IO Element] -> IO Element
+column = grid . map (:[])
+
+-- | Align given elements in a rectangular grid.
+--
+-- Layout is achieved by using the CSS @display:table@ property.
+-- The following element tree will be generated
+--
+-- >
+-- >
+-- >
...
+-- >
+-- >
+-- > ...
+-- >
+-- > ...
+-- >
+--
+-- 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 mrows = do
+ rows0 <- mapM (sequence) mrows
+
+ rows <- forM rows0 $ \row0 -> do
+ row <- forM row0 $ \entry ->
+ wrap "table-cell" [entry]
+ wrap "table-row" row
+ wrap "table" rows
+
+ where
+ wrap c xs = mkElement "div" # set (attr "class") c #+ map element xs
+
+{-----------------------------------------------------------------------------
+ Events
+------------------------------------------------------------------------------}
+-- | Obtain DOM event for a given element.
+domEvent
+ :: String
+ -- ^ Event name. A full list can be found at
+ -- .
+ -- Note that the @on@-prefix is not included,
+ -- the name is @click@ and so on.
+ -> Element -- ^ Element where the event is to occur.
+ -> Event EventData
+domEvent name element = Control.Event.Event $ \handler -> do
+ 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'
+
+-- | Convenience function to register 'Event's for 'Element's.
+--
+-- Example usage.
+--
+-- > on click element $ \_ -> ...
+on :: (element -> Event a) -> element -> (a -> IO void) -> IO ()
+on f x h = register (f x) (void . h) >> return ()
+
+
+{-----------------------------------------------------------------------------
+ Attributes
+------------------------------------------------------------------------------}
+infixl 8 #
+infixl 8 #+
+infixl 8 #.
+
+-- | Reverse function application.
+-- Allows convenient notation for setting properties.
+--
+-- Example usage.
+--
+-- > mkElement "div"
+-- > # set style [("color","#CCAABB")]
+-- > # set draggable True
+-- > # set children otherElements
+(#) :: a -> (a -> b) -> b
+(#) = flip ($)
+
+-- | Convenient combinator for setting the CSS class on element creation.
+(#.) :: IO Element -> String -> IO 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
+
+-- | Attribute that only supports the 'get' operation.
+type ReadAttr x o = ReadWriteAttr x () o
+
+-- | Attribute that only supports the 'set' operation.
+type WriteAttr x i = ReadWriteAttr x i ()
+
+-- | Generalized attribute with different types for getting and setting.
+data ReadWriteAttr x i o = ReadWriteAttr
+ { get' :: x -> IO o
+ , set' :: i -> x -> IO ()
+ }
+
+-- | Set value of an attribute in the 'IO' 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; }
+
+-- | Get attribute value.
+get :: ReadWriteAttr x i o -> x -> IO o
+get = get'
+
+-- | Build an attribute from a getter and a setter.
+mkReadWriteAttr
+ :: (x -> IO o) -- ^ Getter.
+ -> (i -> x -> IO ()) -- ^ 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 get = mkReadWriteAttr get (\_ _ -> return ())
+
+-- | Build attribute from a setter.
+mkWriteAttr :: (i -> x -> IO ()) -> WriteAttr x i
+mkWriteAttr set = mkReadWriteAttr (\_ -> return ()) set
+
diff --git a/src/Graphics/UI/Threepenny/DragNDrop.hs b/src/Graphics/UI/Threepenny/DragNDrop.hs
new file mode 100644
--- /dev/null
+++ b/src/Graphics/UI/Threepenny/DragNDrop.hs
@@ -0,0 +1,111 @@
+module Graphics.UI.Threepenny.DragNDrop (
+ -- * Synopsis
+ -- | API for handling drag and drop operations.
+ --
+ -- See the documentation below for details on the drag and drop model.
+ --
+ -- WARNING: Events in this module may not behave as expected.
+ -- The model is currently implemented in terms of HTML 5 drag and drop,
+ -- but unfortunately,
+ -- the HTML 5 specification for drag and drop is horrible and
+ -- browser implementations are buggy.
+
+ -- * Documentation
+ draggable, droppable, dragData,
+ DragData,
+ drag, dragStart, dragEnd, drop, dragEnter, dragLeave, dragOver,
+ ) where
+
+import Prelude hiding (drop)
+import Control.Monad
+import Graphics.UI.Threepenny.Core
+
+{-----------------------------------------------------------------------------
+ Attributes
+------------------------------------------------------------------------------}
+-- | Enable or disable whether the element can be dragged by the user.
+--
+-- An element with draggable set to 'True' will receive
+-- 'drag', 'dragStart' and 'dragEnd' events.
+draggable :: WriteAttr Element Bool
+draggable = mkWriteAttr set
+ where
+ set v = set' (attr "draggable") $ if v then "true" else "false"
+
+-- | Set the data that is transferred when dragging this element.
+dragData :: WriteAttr Element DragData
+dragData = mkWriteAttr set
+ where
+ set v = set' (attr "ondragstart") $
+ "event.dataTransfer.setData('dragData', '" ++ v ++ "')"
+
+-- | Enable or disable whether the element accepts drops.
+--
+-- An element with 'droppable' set to 'True' will receive
+-- 'drop', 'dragOver', 'dragEnter' and 'dragLeave' events.
+--
+-- Child elements of a 'droppable' element may also be 'droppable'.
+-- When dragging something over an element, the closest ancestor element
+-- that is 'droppable' will be the target and receive corresponding
+-- events.
+droppable :: WriteAttr Element Bool
+droppable = mkWriteAttr enable
+ where
+ enable v = void . if v then allowDrop else blockDrop
+ allowDrop el =
+ element el
+ # set (attr "ondragover") "event.preventDefault()"
+ # set (attr "ondrop" ) "event.preventDefault()"
+ blockDrop el =
+ element el
+ # set (attr "ondragover") ""
+ # set (attr "ondrop" ) ""
+
+{-----------------------------------------------------------------------------
+ Events
+------------------------------------------------------------------------------}
+-- | Data carried by a dragged element.
+--
+-- FIXME: Empty data is currently encoded by the empty String.
+-- Change this to 'Maybe String' instead.
+type DragData = String
+
+
+withDragData = fmap extract
+ where
+ extract (EventData [Just s]) = s
+ extract _ = ""
+
+-- | Occurs periodically while the element is being dragged around.
+drag :: Element -> Event DragData
+drag = withDragData . domEvent "drag"
+
+-- | Dragging the element starts.
+dragStart :: Element -> Event DragData
+dragStart = withDragData . domEvent "dragstart"
+
+-- | Dragging the element ends.
+--
+-- WARNING: This event can occur both before and after a corresponding 'drop' event.
+dragEnd :: Element -> Event DragData
+dragEnd = withDragData . domEvent "dragend"
+
+-- | The element is now the current target element for a 'drop'.
+--
+-- WARNING: This element is buggy when moving the mouse over child elements.
+dragEnter :: Element -> Event DragData
+dragEnter = withDragData . domEvent "dragenter"
+
+-- | Occurs periodically while the element is the current target element.
+dragOver :: Element -> Event DragData
+dragOver = withDragData . domEvent "dragover"
+
+-- | The element is no longer the current target element for a 'drop'.
+--
+-- WARNING: This event is also fired when the mouse is moved over a child element.
+dragLeave :: Element -> Event DragData
+dragLeave = withDragData . domEvent "dragleave"
+
+-- | The drag and drop operation is being completed on this element.
+drop :: Element -> Event DragData
+drop = withDragData . domEvent "drop"
diff --git a/src/Graphics/UI/Threepenny/Elements.hs b/src/Graphics/UI/Threepenny/Elements.hs
new file mode 100644
--- /dev/null
+++ b/src/Graphics/UI/Threepenny/Elements.hs
@@ -0,0 +1,133 @@
+-- | Predefined DOM elements, for convenience.
+module Graphics.UI.Threepenny.Elements (
+ -- * Combinations and utilities
+ addStyleSheet,
+ -- text,
+ new,
+
+ -- * Primitive HTML elements
+ address, a, anchor, applet, area,
+ basefont, big, blockquote, body, bold, br, button,
+ caption, center, cite, 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,
+ 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,
+ underline, variable, video,
+ ) where
+
+import Control.Monad
+import Control.Monad.Trans.Reader
+import Prelude hiding (span,div)
+import Graphics.UI.Threepenny.Core
+
+{-----------------------------------------------------------------------------
+ Combinations
+------------------------------------------------------------------------------}
+-- | Add a stylesheet to the head.
+--
+-- The second argument refers to the filename of the stylesheet,
+-- but not its complete filepath.
+-- Threepenny will prefix the 'css' subdirectory of the 'tpStatic' configuration field
+-- to construct the complete filepath.
+addStyleSheet
+ :: Window
+ -> FilePath
+ -> IO ()
+addStyleSheet w filename = void $ do
+ el <- mkElement "link"
+ # set (attr "rel" ) "stylesheet"
+ # set (attr "type") "text/css"
+ # set (attr "href") ("/static/css/" ++ filename)
+ getHead w #+ [element el]
+
+-- | Make a new @div@ element, synonym for 'div'.
+new :: IO Element
+new = div
+
+{-----------------------------------------------------------------------------
+ Primitives
+
+ Taken from the HTML library (BSD3 license)
+ http://hackage.haskell.org/package/html
+------------------------------------------------------------------------------}
+tag = mkElement
+itag = mkElement
+
+address = tag "address"
+a = anchor
+anchor = tag "a"
+applet = tag "applet"
+area = itag "area"
+basefont = itag "basefont"
+big = tag "big"
+blockquote = tag "blockquote"
+body = tag "body"
+bold = tag "b"
+br = itag "br"
+button = tag "button"
+caption = tag "caption"
+center = tag "center"
+cite = tag "cite"
+ddef = tag "dd"
+define = tag "dfn"
+div = tag "div"
+dlist = tag "dl"
+dterm = tag "dt"
+emphasize = tag "em"
+fieldset = tag "fieldset"
+font = tag "font"
+form = tag "form"
+frame = tag "frame"
+frameset = tag "frameset"
+h1 = tag "h1"
+h2 = tag "h2"
+h3 = tag "h3"
+h4 = tag "h4"
+h5 = tag "h5"
+h6 = tag "h6"
+header = tag "head"
+hr = itag "hr"
+img = image
+image = itag "img"
+input = itag "input"
+italics = tag "i"
+keyboard = tag "kbd"
+legend = tag "legend"
+li = tag "li"
+meta = itag "meta"
+noframes = tag "noframes"
+olist = tag "ol"
+option = tag "option"
+p = tag "p"
+paragraph = tag "p"
+param = itag "param"
+pre = tag "pre"
+sample = tag "samp"
+select = tag "select"
+small = tag "small"
+source = tag "source"
+strong = tag "strong"
+sub = tag "sub"
+sup = tag "sup"
+table = tag "table"
+td = tag "td"
+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"
+tr = tag "tr"
+tt = tag "tt"
+ul = tag "ul"
+underline = tag "u"
+variable = tag "var"
+video = tag "video"
diff --git a/src/Graphics/UI/Threepenny/Events.hs b/src/Graphics/UI/Threepenny/Events.hs
new file mode 100644
--- /dev/null
+++ b/src/Graphics/UI/Threepenny/Events.hs
@@ -0,0 +1,27 @@
+module Graphics.UI.Threepenny.Events (
+ -- * Synopsis
+ -- | Common DOM events, for convenience.
+
+ -- * Documentation
+ click, hover, blur, leave,
+ ) where
+
+import Graphics.UI.Threepenny.Core
+
+silence = fmap (const ())
+
+-- | Mouse click.
+click :: Element -> Event ()
+click = silence . domEvent "click"
+
+-- | Mouse hovering over an element.
+hover :: Element -> Event ()
+hover = silence . domEvent "mouseenter"
+
+-- | Mouse leaving an element.
+leave :: Element -> Event ()
+leave = silence . domEvent "mouseleave"
+
+-- | Element loses focus.
+blur :: Element -> Event ()
+blur = silence . domEvent "blur"
diff --git a/src/Graphics/UI/Threepenny/Internal/Core.hs b/src/Graphics/UI/Threepenny/Internal/Core.hs
new file mode 100644
--- /dev/null
+++ b/src/Graphics/UI/Threepenny/Internal/Core.hs
@@ -0,0 +1,601 @@
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS -fno-warn-name-shadowing #-}
+
+-- | The main Threepenny module.
+
+
+--------------------------------------------------------------------------------
+-- Exports
+
+module Graphics.UI.Threepenny.Internal.Core
+ (
+ -- * Server running
+ serve
+ ,loadFile
+ ,loadDirectory
+
+ -- * Event handling
+ -- $eventhandling
+ ,bind
+ ,handleEvent
+ ,handleEvents
+ ,module Control.Event
+
+ -- * Setting attributes
+ -- $settingattributes
+ ,setStyle
+ ,setAttr
+ ,setText
+ ,setHtml
+ ,setTitle
+ ,emptyEl
+ ,delete
+
+ -- * Manipulating tree structure
+ -- $treestructure
+ ,newElement
+ ,appendElementTo
+
+ -- * Querying
+ -- $querying
+ ,getHead
+ ,getBody
+ ,getElementsByTagName
+ ,getElementsById
+ ,getWindow
+ ,getValue
+ ,getValuesList
+ ,readValue
+ ,readValuesList
+ ,getRequestCookies
+ ,getRequestLocation
+
+ -- * Utilities
+ ,debug
+ ,clear
+ ,callFunction
+ ,runFunction
+ ,callDeferredFunction
+ ,atomic
+
+ -- * Types
+ ,Window
+ ,Element
+ ,Config(..)
+ ,EventData(..)
+ ) where
+
+
+--------------------------------------------------------------------------------
+-- Imports
+
+import Graphics.UI.Threepenny.Internal.Types as Threepenny
+import Graphics.UI.Threepenny.Internal.Resources
+
+import Control.Applicative
+import Control.Concurrent
+import Control.Concurrent.Chan.Extra
+import Control.Concurrent.Delay
+import qualified Control.Exception as E
+import Control.Event
+import Control.Monad.IO
+import Control.Monad.Reader
+import Data.ByteString (ByteString)
+import Data.ByteString.UTF8 (toString,fromString)
+import Data.Map (Map)
+import qualified Data.Map as M
+import Data.Maybe
+import Data.Text (Text,pack,unpack)
+import qualified Data.Text as Text
+import Data.Text.Encoding
+import Data.Time
+import Network.URI
+import Prelude hiding (init)
+import Safe
+import Snap.Core
+import Snap.Http.Server hiding (Config)
+import Snap.Util.FileServe
+import System.FilePath
+import Text.JSON.Generic
+
+
+{-----------------------------------------------------------------------------
+ Server running
+------------------------------------------------------------------------------}
+newServerState :: IO ServerState
+newServerState = ServerState
+ <$> newMVar M.empty
+ <*> newMVar (0,M.empty)
+ <*> newMVar (0,M.empty)
+
+-- | Run a TP server with Snap on the specified port and the given
+-- worker action.
+serve :: Config -> (Session -> IO ()) -> IO () -- ^ A TP server.
+serve Config{..} worker = do
+ server <- newServerState
+ _ <- forkIO $ custodian 30 (sSessions server)
+ httpServe config (router tpCustomHTML tpStatic worker server)
+ where config = setPort tpPort defaultConfig
+
+-- | Kill sessions after at least n seconds of disconnectedness.
+custodian :: Integer -> MVar Sessions -> IO ()
+custodian seconds sessions = forever $ do
+ delaySeconds seconds
+ modifyMVar_ sessions $ \sessions -> do
+ killed <- fmap catMaybes $ forM (M.assocs sessions) $ \(key,Session{..}) -> do
+ state <- readMVar sConnectedState
+ case state of
+ Connected -> return Nothing
+ Disconnected time -> do
+ now <- getCurrentTime
+ let dcSeconds = diffUTCTime now time
+ if (dcSeconds > fromIntegral seconds)
+ then do killThread sThreadId
+ return (Just key)
+ else return Nothing
+
+ return (M.filterWithKey (\k _ -> not (k `elem` killed)) sessions)
+
+-- Route requests. If the initFile is Nothing, then a default
+-- file will be served at /.
+router
+ :: Maybe FilePath
+ -> FilePath
+ -> (Session -> IO a)
+ -> ServerState
+ -> Snap ()
+router customHTML wwwroot worker server =
+ route [("/static" , serveDirectory wwwroot)
+ ,("/" , root)
+ ,("/driver/threepenny-gui.js" , writeText jsDriverCode )
+ ,("/driver/threepenny-gui.css" , writeText cssDriverCode)
+ ,("/init" , init worker server)
+ ,("/poll" , withSession server poll )
+ ,("/signal" , withSession server signal)
+ ,("/file/:name" ,
+ withFilepath (sFiles server) (flip serveFileAs))
+ ,("/dir/:name" ,
+ withFilepath (sDirs server) (\path _ -> serveDirectory path))
+ ]
+ where
+ root = case customHTML of
+ Just file -> serveFile (wwwroot file)
+ Nothing -> writeText defaultHtmlFile
+
+-- Get a filename from a URI
+withFilepath :: MVar Filepaths -> (FilePath -> MimeType -> Snap a) -> Snap a
+withFilepath rDict cont = do
+ mName <- getParam "name"
+ (_,dict) <- io $ withMVar rDict return
+ case (\key -> M.lookup key dict) =<< mName of
+ Just (path,mimetype) -> cont path mimetype
+ Nothing -> error $ "File not loaded: " ++ show mName
+
+-- FIXME: Serving large files fails with the exception
+-- System.SendFile.Darwin: invalid argument (Socket is not connected)
+
+
+newAssociation :: MVar Filepaths -> (FilePath, MimeType) -> IO String
+newAssociation rDict (path,mimetype) = do
+ (old, dict) <- takeMVar rDict
+ let new = old + 1; key = show new ++ takeFileName path
+ putMVar rDict $ (new, M.insert (fromString key) (path,mimetype) dict)
+ return key
+
+-- | Begin to serve a local file under an URI.
+loadFile :: Session -> MimeType -> FilePath -> IO String
+loadFile Session{..} mimetype path = do
+ key <- newAssociation (sFiles sServerState) (path,mimetype)
+ return $ "/file/" ++ key
+
+-- | Begin to serve a local directory under an URI.
+loadDirectory :: Session -> FilePath -> IO String
+loadDirectory Session{..} path = do
+ key <- newAssociation (sDirs sServerState) (path,"")
+ return $ "/dir/" ++ key
+
+-- Initialize the session.
+init :: (Session -> IO void) -> ServerState -> Snap ()
+init sessionThread server = do
+ uri <- getRequestURI
+ params <- getRequestCookies
+ key <- io $ modifyMVar (sSessions server) $ \sessions -> do
+ let newKey = maybe 0 (+1) (lastMay (M.keys sessions))
+ session <- newSession server (uri,params) newKey
+ _ <- forkIO $ do _ <- sessionThread session; return ()
+ return (M.insert newKey session sessions,newKey)
+ modifyResponse $ setHeader "Set-Token" (fromString (show key))
+ withGivenSession key server poll
+
+ where getRequestURI = do
+ uri <- getInput "info"
+ maybe (error ("Unable to parse request URI: " ++ show uri)) return (uri >>= parseURI)
+ getRequestCookies = do
+ cookies <- getsRequest rqCookies
+ return $ flip map cookies $ \Cookie{..} -> (toString cookieName,toString cookieValue)
+
+-- Make a new session.
+newSession :: ServerState -> (URI,[(String, String)]) -> Integer -> IO Session
+newSession server info token = do
+ signals <- newChan
+ instructions <- newChan
+ (event, handler) <- newEventsTagged
+ ids <- newMVar [0..]
+ mutex <- newMVar ()
+ now <- getCurrentTime
+ conState <- newMVar (Disconnected now)
+ threadId <- myThreadId
+ closures <- newMVar [0..]
+ return $ Session
+ { sSignals = signals
+ , sInstructions = instructions
+ , sEvent = event
+ , sEventHandler = handler
+ , sElementIds = ids
+ , sToken = token
+ , sMutex = mutex
+ , sConnectedState = conState
+ , sThreadId = threadId
+ , sClosures = closures
+ , sStartInfo = info
+ , sServerState = server
+ }
+
+-- Respond to poll requests.
+poll :: Session -> Snap ()
+poll Session{..} = do
+ let setDisconnected = do
+ now <- getCurrentTime
+ modifyMVar_ sConnectedState (const (return (Disconnected now)))
+ io $ modifyMVar_ sConnectedState (const (return Connected))
+ threadId <- io $ myThreadId
+ _ <- io $ forkIO $ do
+ delaySeconds $ 60 * 5 -- Force kill after 5 minutes.
+ killThread threadId
+ instructions <- io $ E.catch (readAvailableChan sInstructions) $ \e -> do
+ when (e == E.ThreadKilled) $ do
+ setDisconnected
+ E.throw e
+ writeJson instructions
+
+-- Write JSON to output.
+writeJson :: (MonadSnap m, Data a) => a -> m ()
+writeJson json = do
+ modifyResponse $ setContentType "application/json"
+ (writeString . encodeJSON) json
+
+-- Write a string to output.
+writeString :: (MonadSnap m) => String -> m ()
+writeString = writeText . pack
+
+-- Handle signals sent from the client.
+signal :: Session -> Snap ()
+signal Session{..} = do
+ input <- getInput "signal"
+ case input of
+ Just signalJson -> do
+ let signal = decode signalJson
+ case signal of
+ Ok signal -> io $ writeChan sSignals signal
+ Error err -> error err
+ Nothing -> error $ "Unable to parse " ++ show input
+
+-- Get a text input from snap.
+getInput :: (MonadSnap f) => ByteString -> f (Maybe String)
+getInput = fmap (fmap (unpack . decodeUtf8)) . getParam
+
+-- Run a snap action with the given session.
+withSession :: ServerState -> (Session -> Snap a) -> Snap a
+withSession server cont = do
+ token <- readInput "token"
+ case token of
+ Nothing -> error $ "Invalid session token format."
+ Just token -> withGivenSession token server cont
+
+-- Do something with the session given by its token id.
+withGivenSession :: Integer -> ServerState -> (Session -> Snap a) -> Snap a
+withGivenSession token ServerState{..} cont = do
+ sessions <- io $ withMVar sSessions return
+ case M.lookup token sessions of
+ Nothing -> error $ "Nonexistant token: " ++ show token
+ Just session -> cont session
+
+-- Read an input from snap.
+readInput :: (MonadSnap f,Read a) => ByteString -> f (Maybe a)
+readInput = fmap (>>= readMay) . getInput
+
+--------------------------------------------------------------------------------
+-- Event handling
+--
+-- $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
+
+-- | Handle one event.
+handleEvent :: Window -> IO ()
+handleEvent window@(Session{..}) = do
+ signal <- getSignal window
+ case signal of
+ Threepenny.Event (elid,eventType,params) -> do
+ sEventHandler ((elid,eventType), EventData params)
+ _ -> return ()
+
+-- Get the latest signal sent from the client.
+getSignal :: Window -> IO Signal
+getSignal (Session{..}) = readChan sSignals
+
+-- | Return an 'Event' associated to an 'Element'.
+bind
+ :: String -- ^ The eventType, see any DOM documentation for a list of these.
+ -> Element -- ^ The element to bind to.
+ -> Event EventData -- ^ The event handler.
+bind eventType (Element el@(ElementId elid) session) =
+ Control.Event.Event register
+ where
+ key = (elid, eventType)
+ register h = do
+ -- register with server
+ unregister <- Control.Event.register (sEvent session key) h
+ -- register with client
+ run session $ Bind eventType el (Closure key)
+ return unregister
+
+-- Make a uniquely numbered event handler.
+newClosure :: Window -> String -> String -> ([Maybe String] -> IO ()) -> IO Closure
+newClosure window@(Session{..}) eventType elid thunk = do
+ let key = (elid, eventType)
+ _ <- 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.
+
+-- | Set the style of the given element.
+setStyle :: [(String, String)] -- ^ Pairs of CSS (property,value).
+ -> Element -- ^ The element to update.
+ -> IO ()
+setStyle props e@(Element el session) = run session $ SetStyle el props
+
+-- | Set the attribute of the given element.
+setAttr :: String -- ^ The attribute name.
+ -> String -- ^ The attribute value.
+ -> Element -- ^ The element to update.
+ -> IO ()
+setAttr key value e@(Element el session) = run session $ SetAttr el key value
+
+-- | Set the text of the given element.
+setText :: String -- ^ The plain text.
+ -> Element -- ^ The element to update.
+ -> IO ()
+setText props e@(Element el session) = run session $ SetText el props
+
+-- | Set the HTML of the given element.
+setHtml :: String -- ^ The HTML.
+ -> Element -- ^ The element to update.
+ -> IO ()
+setHtml props e@(Element el session) = run session $ SetHtml el props
+
+-- | Set the title of the document.
+setTitle
+ :: String -- ^ The title.
+ -> Window -- ^ The document window
+ -> IO ()
+setTitle title session = run session $ SetTitle title
+
+-- | Empty the given element.
+emptyEl :: Element -> IO ()
+emptyEl e@(Element el session) = run session $ EmptyEl el
+
+-- | Delete the given element.
+delete :: Element -> IO ()
+delete e@(Element el session) = run session $ Delete el
+
+
+--------------------------------------------------------------------------------
+-- Manipulating tree structure
+--
+-- $treestructure
+--
+-- Functions for creating, deleting, moving, appending, prepending, DOM nodes.
+
+-- | Create a new element of the given tag name.
+newElement :: Window -- ^ Browser window in which context to create the element
+ -> String -- ^ The tag name.
+ -> IO Element -- ^ A tag reference. Non-blocking.
+newElement session@(Session{..}) tagName = do
+ -- TODO: Remove the need to specify in which browser window is to be created
+ elid <- modifyMVar sElementIds $ \elids ->
+ return (tail elids,"*" ++ show (head elids) ++ ":" ++ tagName)
+ return (Element (ElementId elid) session)
+
+-- | Append a child element to a parent element. Non-blocking.
+appendElementTo
+ :: Element -- ^ Parent.
+ -> Element -- ^ Child.
+ -> IO ()
+appendElementTo (Element parent session) e@(Element child _) =
+ -- TODO: Right now, parent and child need to be from the same session/browser window
+ -- Implement transfer of elements across browser windows
+ run session $ Append parent child
+
+
+--------------------------------------------------------------------------------
+-- Querying the DOM
+--
+-- $querying
+--
+-- The DOM can be searched for elements of a given name, and nodes can
+-- be inspected for their values.
+
+-- | Get all elements of the given tag name. Blocks.
+getElementsByTagName
+ :: Window -- ^ Browser window
+ -> String -- ^ The tag name.
+ -> IO [Element] -- ^ All elements with that tag name.
+getElementsByTagName window tagName =
+ call window (GetElementsByTagName tagName) $ \signal ->
+ case signal of
+ Elements els -> return $ Just $ [Element el window | el <- els]
+ _ -> return Nothing
+
+-- | Get a list of elements by particular IDs. Blocks.
+getElementsById
+ :: Window -- ^ Browser window
+ -> [String] -- ^ The ID string.
+ -> IO [Element] -- ^ Elements with given ID.
+getElementsById window ids =
+ call window (GetElementsById ids) $ \signal ->
+ case signal of
+ Elements els -> return $ Just [Element el window | el <- els]
+ _ -> return Nothing
+
+-- | Get the value of an input. Blocks.
+getValue
+ :: Element -- ^ The element to get the value of.
+ -> IO String -- ^ The plain text value.
+getValue e@(Element el window) =
+ call window (GetValue el) $ \signal ->
+ case signal of
+ Value str -> return (Just str)
+ _ -> return Nothing
+
+-- | Get 'Window' associated to an 'Element'.
+getWindow :: Element -> Window
+getWindow (Element _ window) = window
+
+-- | Get values from inputs. Blocks. This is faster than many 'getValue' invocations.
+getValuesList
+ :: [Element] -- ^ A list of elements to get the values of.
+ -> IO [String] -- ^ The list of plain text values.
+getValuesList [] = return []
+getValuesList es@(Element _ window : _) =
+ let elids = [elid | Element elid _ <- es] in
+ call window (GetValues elids) $ \signal ->
+ case signal of
+ Values strs -> return $ Just strs
+ _ -> return Nothing
+
+-- | Read a value from an input. Blocks.
+readValue
+ :: Read a
+ => Element -- ^ The element to read a value from.
+ -> IO (Maybe a) -- ^ Maybe the read value.
+readValue = liftM readMay . getValue
+
+-- | Read values from inputs. Blocks. This is faster than many 'readValue' invocations.
+readValuesList
+ :: Read a
+ => [Element] -- ^ The element to read a value from.
+ -> IO (Maybe [a]) -- ^ Maybe the read values. All or none.
+readValuesList = liftM (sequence . map readMay) . getValuesList
+
+-- | Atomically execute the given computation in the context of a browser window
+atomic :: Window -> IO a -> IO a
+atomic window@(Session{..}) m = do
+ takeMVar sMutex
+ ret <- m
+ putMVar sMutex ()
+ return ret
+
+
+-- Send an instruction and read the signal response.
+call :: Session -> Instruction -> (Signal -> IO (Maybe a)) -> IO a
+call session@(Session{..}) instruction withSignal = do
+ takeMVar sMutex
+ run session $ instruction
+ newChan <- dupChan sSignals
+ go sMutex newChan
+
+ where
+ go mutex newChan = do
+ signal <- readChan newChan
+ result <- withSignal signal
+ case result of
+ Just signal -> do putMVar mutex ()
+ return signal
+ Nothing -> go mutex newChan
+
+-- Run the given instruction.
+run :: Session -> Instruction -> IO ()
+run (Session{..}) i = writeChan sInstructions i
+
+-- | Get the head of the page.
+getHead :: Window -> IO Element
+getHead session = return $ Element (ElementId "head") session
+
+-- | Get the body of the page.
+getBody :: Window -> IO Element
+getBody session = return $ Element (ElementId "body") session
+
+-- | Get the request location.
+getRequestLocation :: Window -> IO URI
+getRequestLocation = return . fst . sStartInfo
+
+-- | Get the request cookies.
+getRequestCookies :: Window -> IO [(String,String)]
+getRequestCookies = return . snd . sStartInfo
+
+
+--------------------------------------------------------------------------------
+-- Utilities
+
+-- | Send a debug message to the client. The behaviour of the client
+-- is unspecified.
+debug
+ :: Window -- ^ Client window
+ -> String -- ^ Some plain text to send to the client.
+ -> IO ()
+debug window = run window . Debug
+
+-- | Clear the client's DOM.
+clear :: Window -> IO ()
+clear window = 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
+
+-- | 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)
+
+-- | Call the given function with the given continuation. Doesn't block.
+callDeferredFunction
+ :: Window -- ^ Browser window
+ -> String -- ^ The function name.
+ -> [String] -- ^ Parameters.
+ -> ([Maybe String] -> IO ()) -- ^ The continuation to call if/when the function completes.
+ -> IO ()
+callDeferredFunction session@(Session{..}) func params closure = do
+ cid <- modifyMVar sClosures (\(x:xs) -> return (xs,x))
+ closure' <- newClosure session func (show cid) closure
+ run session $ CallDeferredFunction (closure',func,params)
diff --git a/src/Graphics/UI/Threepenny/Internal/Resources.hs b/src/Graphics/UI/Threepenny/Internal/Resources.hs
new file mode 100644
--- /dev/null
+++ b/src/Graphics/UI/Threepenny/Internal/Resources.hs
@@ -0,0 +1,54 @@
+{-# LANGUAGE QuasiQuotes, CPP #-}
+module Graphics.UI.Threepenny.Internal.Resources where
+
+import Data.Text (Text)
+import qualified Data.Text as Text
+import qualified Data.Text.IO as Text
+import System.FilePath
+import System.IO.Unsafe
+
+#ifdef CABAL
+import qualified Paths_threepenny_gui
+getDataDir = fmap ( "src" "Graphics" "UI") Paths_threepenny_gui.getDataDir
+
+#else
+getDataDir = return $ "Graphics" "UI"
+#endif
+
+
+jsDriverCode :: Text
+cssDriverCode :: Text
+defaultHtmlFile :: Text
+
+
+jsDriverCode = unsafePerformIO $
+ readFiles $ words "jquery.js jquery-cookie.js driver.js"
+
+cssDriverCode = unsafePerformIO $
+ readFiles ["driver.css"]
+
+defaultHtmlFile = unsafePerformIO $
+ readFiles ["index.html"]
+
+readFiles files = do
+ ys <- mapM (Text.readFile . getDataFile) files
+ return $ Text.unlines ys
+
+getDataFile x = unsafePerformIO $ fmap ( x) getDataDir
+
+
+{-
+-- Temporarily disabled code.
+-- Use quasiquotation to bundle resource files with executable.
+
+jsDriverCode = Text.unlines $ map Text.pack
+ [ [include|Graphics/UI/jquery.js|]
+ , [include|Graphics/UI/jquery-cookie.js|]
+ , [include|Graphics/UI/driver.js|]
+ ]
+
+cssDriverCode = Text.pack [include|Graphics/UI/driver.css|]
+
+defaultHtmlFile = Text.pack [include|Graphics/UI/index.html|]
+
+-}
diff --git a/src/Graphics/UI/Threepenny/Internal/Types.hs b/src/Graphics/UI/Threepenny/Internal/Types.hs
new file mode 100644
--- /dev/null
+++ b/src/Graphics/UI/Threepenny/Internal/Types.hs
@@ -0,0 +1,161 @@
+{-# 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.
+
+module Graphics.UI.Threepenny.Internal.Types
+ where
+
+import Prelude hiding ((++),init)
+
+import Control.Applicative
+import Control.Concurrent
+import qualified Control.Event as E
+import Control.Monad.Reader
+import Data.ByteString (ByteString)
+import Data.Map (Map)
+import Data.Time
+
+import Network.URI
+import Text.JSON.Generic
+
+--------------------------------------------------------------------------------
+-- Public types
+
+-- | Reference to an element in the DOM of the client window.
+data Element = Element
+ { elId :: ElementId
+ , elSession :: Session
+ }
+
+instance Show Element where
+ show = show . elId
+
+-- | An opaque reference to an element in the DOM.
+data ElementId = ElementId String
+ deriving (Data,Typeable,Show)
+
+instance JSON ElementId where
+ showJSON (ElementId o) = showJSON o
+ readJSON obj = do
+ obj <- readJSON obj
+ ElementId <$> valFromObj "Element" obj
+
+
+-- | A client session. This type is opaque, you don't need to inspect it.
+data Session = Session
+ { sSignals :: Chan Signal
+ , sInstructions :: Chan Instruction
+ , sEvent :: EventKey -> E.Event EventData
+ , sEventHandler :: E.Handler (EventKey, EventData)
+ , sClosures :: MVar [Integer]
+ , sElementIds :: MVar [Integer]
+ , sToken :: Integer
+ , sMutex :: MVar ()
+ , sConnectedState :: MVar ConnectedState
+ , sThreadId :: ThreadId
+ , sStartInfo :: (URI,[(String,String)])
+ , sServerState :: ServerState
+ }
+
+type Sessions = Map Integer Session
+type MimeType = ByteString
+type Filepaths = (Integer, Map ByteString (FilePath, MimeType))
+
+data ServerState = ServerState
+ { sSessions :: MVar Sessions
+ , sFiles :: MVar Filepaths
+ , sDirs :: MVar Filepaths
+ }
+
+type EventKey = (String, String)
+
+-- | The client browser window.
+type Window = Session
+
+data ConnectedState
+ = Disconnected UTCTime -- ^ The time that the poll disconnected, or
+ -- the first initial connection time.
+ | Connected -- ^ The client is connected, we don't care
+ -- since when.
+ deriving (Show)
+
+-- | Data from an event. At the moment it is empty.
+data EventData = EventData [Maybe String]
+
+--------------------------------------------------------------------------------
+-- Internal types
+
+-- | An instruction that is sent to the client as JSON.
+data Instruction
+ = Debug String
+ | Begin ()
+ | End ()
+ | SetToken Integer
+ | Clear ()
+ | GetElementsById [String]
+ | GetElementsByTagName String
+ | SetStyle ElementId [(String,String)]
+ | SetAttr ElementId String String
+ | Append ElementId ElementId
+ | SetText ElementId String
+ | SetHtml ElementId String
+ | Bind String ElementId Closure
+ | GetValue ElementId
+ | GetValues [ElementId]
+ | SetTitle String
+ | GetLocation ()
+ | CallFunction (String,[String])
+ | CallDeferredFunction (Closure,String,[String])
+ | EmptyEl ElementId
+ | Delete ElementId
+ deriving (Typeable,Data,Show)
+
+-- | A signal (mostly events) that are sent from the client to the server.
+data Signal
+ = Init ()
+ | Elements [ElementId]
+ | Event (String,String,[Maybe String])
+ | Value String
+ | Values [String]
+ | Location String
+ | FunctionCallValues [Maybe String]
+ deriving (Show)
+
+instance JSON Signal where
+ showJSON _ = error "JSON.Signal.showJSON: No method implemented."
+ readJSON obj = do
+ obj <- readJSON obj
+ let init = Init <$> valFromObj "Init" obj
+ elements = Elements <$> valFromObj "Elements" obj
+ event = do
+ (cid,typ,arguments) <- valFromObj "Event" obj
+ args <- mapM nullable arguments
+ return $ Event (cid,typ,args)
+ value = Value <$> valFromObj "Value" obj
+ location = Location <$> valFromObj "Location" obj
+ values = Values <$> valFromObj "Values" obj
+ fcallvalues = do
+ FunctionCallValues <$> (valFromObj "FunctionCallValues" obj >>= mapM nullable)
+ init <|> elements <|> event <|> value <|> values <|> location <|> fcallvalues
+
+-- | Read a JSValue that may be null.
+nullable :: JSON a => JSValue -> Result (Maybe a)
+nullable JSNull = return Nothing
+nullable v = Just <$> readJSON v
+
+-- | An opaque reference to a closure that the event manager uses to
+-- trigger events signalled by the client.
+data Closure = Closure (String,String)
+ 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@.
+ }
diff --git a/src/Graphics/UI/Threepenny/JQuery.hs b/src/Graphics/UI/Threepenny/JQuery.hs
new file mode 100644
--- /dev/null
+++ b/src/Graphics/UI/Threepenny/JQuery.hs
@@ -0,0 +1,53 @@
+{-# OPTIONS -fno-warn-wrong-do-bind #-}
+module Graphics.UI.Threepenny.JQuery where
+
+import Control.Event
+import Control.Arrow
+import Data.Char
+import Data.Default
+import Data.Maybe
+import Graphics.UI.Threepenny.Core
+import qualified Graphics.UI.Threepenny.Internal.Core as Core
+import qualified Graphics.UI.Threepenny.Internal.Types as Core
+import Text.JSON
+
+data Easing = Swing | Linear
+ deriving (Eq,Enum,Show)
+
+instance Default Easing where
+ def = Linear
+
+-- | Animate property changes of a function.
+animate :: Element -> [(String,String)] -> Int -> Easing -> IO () -> IO ()
+animate el props duration easing complete =
+ flip updateElement el $ \(Core.Element el window) ->
+ callDeferredFunction window
+ "jquery_animate"
+ [encode el,encode (makeObj (map (second showJSON) props)),show duration,map toLower (show easing)]
+ (const complete)
+
+-- | Fade in an element.
+fadeIn :: Element -> Int -> Easing -> IO () -> IO ()
+fadeIn el duration easing complete =
+ animate el [("opacity","1")] duration easing complete
+
+-- | Fade out an element.
+fadeOut :: Element -> Int -> Easing -> IO () -> IO ()
+fadeOut el duration easing complete =
+ animate el [("opacity","0")] duration easing complete
+
+-- | Do something on return.
+sendValue :: Element -> Event String
+sendValue el = fmap f (domEvent "sendvalue" el)
+ where
+ f (EventData x) = concat . catMaybes $ x
+
+-- | Focus an element.
+setFocus :: Element -> IO ()
+setFocus = updateElement $ \(Core.Element el window) ->
+ runFunction window "jquery_setFocus" [encode el]
+
+-- | Scroll to the bottom of an element.
+scrollToBottom :: Element -> IO ()
+scrollToBottom = updateElement $ \(Core.Element area window) ->
+ runFunction window "jquery_scrollToBottom" [encode area]
diff --git a/src/Graphics/UI/driver.css b/src/Graphics/UI/driver.css
new file mode 100644
--- /dev/null
+++ b/src/Graphics/UI/driver.css
@@ -0,0 +1,3 @@
+.tabel { display: table; }
+.table-row { display: table-row; }
+.table-cell { display: table-cell; }
diff --git a/src/Graphics/UI/driver.js b/src/Graphics/UI/driver.js
new file mode 100644
--- /dev/null
+++ b/src/Graphics/UI/driver.js
@@ -0,0 +1,435 @@
+$.fn.sendvalue = function(trigger){
+ $(this).each(function(){
+ var self = this;
+ var el = $(self);
+ el.keydown(function(e){
+ if(e.which == 13) {
+ trigger.call(self,el.val());
+ return false;
+ }
+ else
+ return true;
+ });
+ });
+};
+
+$.fn.livechange = function(ms,trigger){
+ $(this).each(function(){
+ var self = this;
+ var el = $(self);
+ var last_val;
+ var check = function(){
+ var val = el.val();
+ if(val != last_val)
+ trigger.call(self);
+ last_val = val;
+ };
+ var checker;
+ var restart = function(){
+ clearTimeout(checker);
+ checker = setInterval(check,ms);
+ };
+ restart();
+ el.keypress(restart).change(restart);
+ });
+};
+
+(function(){
+
+ ////////////////////////////////////////////////////////////////////////////////
+ // State
+ var sessionToken = null;
+ var element_count = 0, el_table = {};
+ var tp_enable_log = $.cookie('tp_log') == "true";
+ var signal_count = 0;
+
+ document.head = document.head || document.getElementsByTagName('head')[0];
+
+ ////////////////////////////////////////////////////////////////////////////////
+ // Main entry point
+ $(document).ready(function(){
+ setTimeout(function(){
+ waitForEvents();
+ })
+ });
+
+ ////////////////////////////////////////////////////////////////////////////////
+ // Running instructions
+
+ 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 };
+ var cmd = sessionToken != null? 'poll' : 'init';
+ if(cmd == 'init')
+ data.info = window.location.href;
+ var req = $.ajax({
+ dataType: 'json',
+ url: cmd,
+ data: data,
+ success: function(events){
+ if(sessionToken == null) {
+ sessionToken = req.getResponseHeader('Set-Token').match(/[0-9]+/)*1;
+ }
+ console_log("Running event" +(events.length>1?'s':'') +"…")
+ if(events.length){
+ console_log('Event list:');
+ runMultipleEvents(events);
+ } else {
+ runEvent(events,function(){
+ waitForEvents();
+ });
+ }
+ },
+ error: function(reply){
+ console_log("Error, waiting…");
+ setTimeout(function(){
+ waitForEvents();
+ },5000);
+ }
+ });
+ }
+
+ function runMultipleEvents(events){
+ if(events.length == 0) {
+ return waitForEvents();
+ }
+ runEvent(events.shift(),function(){
+ runMultipleEvents(events);
+ });
+ }
+
+ function runEvent(event,continuation){
+ console_log("Event: %s",JSON.stringify(event));
+ for(var key in event){
+ switch(key){
+ case "EmptyEl": {
+ var id = event.EmptyEl;
+ var el = elidToElement(id);
+ // Detach child elements without deleting associated event handlers and data.
+ // It is not correct to remove the child elements from the el_table
+ // because they may still be present on the server side.
+ $(el).contents().detach();
+ continuation();
+ break;
+ }
+ case "CallDeferredFunction": {
+ var call = event.CallDeferredFunction;
+ var closure = call[0];
+ var theFunction = eval(call[1]);
+ var params = call[2];
+ theFunction.apply(window, params.concat(function(){
+ console_log(this);
+ var args = Array.prototype.slice.call(arguments,0);
+ signal({
+ Event: closure.concat([args])
+ },function(){
+ // No action.
+ });
+ }));
+ 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();
+ });
+ }));
+ break;
+ }
+ case "Delete": {
+ event_delete(event);
+ continuation();
+ break;
+ }
+ case "Debug": {
+ if(window.console)
+ console.log("Server debug: %o",event.Debug);
+ continuation();
+ break;
+ }
+ case "Clear": {
+ $('body').contents().detach();
+ continuation();
+ break;
+ }
+ case "GetElementsByTagName": {
+ var elements = document.getElementsByTagName(event.GetElementsByTagName);
+ var els = [];
+ var len = elements.length;
+ for(var i = 0; i < len; i++) {
+ els.push({
+ Element: elementToElid(elements[i])
+ });
+ }
+ signal({
+ Elements: els
+ },function(){
+ continuation();
+ });
+ break;
+ }
+ case "GetElementsById": {
+ // Note that this is the html ID, not the elid that is the key of the el_table.
+ var ids = event.GetElementsById;
+ var els = [];
+ for(var i = 0; i < ids.length; i++) {
+ var match = document.getElementById(ids[i]);
+ if (match != null) {
+ els.push({
+ Element: elementToElid(match)
+ });
+ }
+ }
+ signal({
+ Elements: els
+ },function(){
+ continuation();
+ });
+ break;
+ }
+ case "SetStyle": {
+ var set = event.SetStyle;
+ var id = set[0];
+ var style = set[1];
+ var el = elidToElement(id);
+ var len = style.length;
+ for(var i = 0; i < len; i++){
+ el.style[style[i][0]] = style[i][1];
+ }
+ continuation();
+ break;
+ }
+ case "SetAttr": {
+ var set = event.SetAttr;
+ var id = set[0];
+ var key = set[1];
+ var value = set[2];
+ var el = elidToElement(id);
+ $(el).attr(key,value);
+ continuation();
+ break;
+ }
+ case "GetValue": {
+ var id = event.GetValue;
+ var el = elidToElement(id);
+ var value = $(el).val();
+ signal({
+ Value: value
+ },function(){
+ continuation();
+ });
+ break;
+ }
+ case "GetLocation": {
+ signal({
+ Location: window.location.href
+ },function(){
+ continuation();
+ });
+ break;
+ }
+ case "GetValues": {
+ var ids = event.GetValues;
+ var len = ids.length;
+ var values = [];
+ for(var i = 0; i < len; i++) {
+ values.push($(elidToElement(ids[i])).val());
+ }
+ signal({
+ Values: values
+ },function(){
+ continuation();
+ });
+ break;
+ }
+ case "Append": {
+ var append = event.Append;
+ $(elidToElement(append[0])).append($(elidToElement(append[1])));
+ continuation();
+ break;
+ }
+ case "SetText": {
+ var set = event.SetText;
+ $(elidToElement(set[0])).text(set[1]);
+ continuation();
+ break;
+ }
+ case "SetTitle": {
+ document.title = event.SetTitle;
+ continuation();
+ break;
+ }
+ case "SetHtml": {
+ var set = event.SetHtml;
+ $(elidToElement(set[0])).html(set[1]);
+ continuation();
+ break;
+ }
+ case "Bind": {
+ var bind = event.Bind;
+ var eventType = bind[0];
+ var handlerGuid = bind[2];
+ var el = elidToElement(bind[1]);
+ console_log('event type: ' + eventType);
+ if(eventType == 'livechange') {
+ $(el).livechange(300,function(e){
+ signal({
+ Event: handlerGuid.concat([[$(el).val()]])
+ },function(){
+ // no action
+ });
+ return true;
+ });
+ } else if(eventType == 'sendvalue') {
+ $(el).sendvalue(function(x){
+ signal({
+ Event: handlerGuid.concat([[x]])
+ },function(){});
+ });
+ } else if(eventType.match('dragstart|dragenter|dragover|dragleave|drag|drop|dragend')) {
+ $(el).bind(eventType,function(e){
+ signal({
+ Event: handlerGuid.concat([
+ e.originalEvent.dataTransfer
+ ?[e.originalEvent.dataTransfer.getData("dragData")]
+ :[]])
+ },function(){
+ // no action
+ });
+ return true;
+ });
+ } else {
+ $(el).bind(eventType,function(e){
+ signal({
+ Event: handlerGuid.concat([e.which?[e.which.toString()]:[]])
+ },function(){
+ // no action
+ });
+ return true;
+ });
+ }
+ continuation();
+ break;
+ }
+ default: continuation();
+ }
+ }
+ }
+
+ function event_delete(event){
+ var id = event.Delete;
+ var el = elidToElement(id);
+ // TODO: Think whether it is correct to remove element ids
+ $(el).detach();
+ deleteElementTable(id);
+ }
+
+ ////////////////////////////////////////////////////////////////////////////////
+ // Signalling events
+
+ function signal(signal,continuation){
+ signal_count++;
+ console_log('Signal: %s',JSON.stringify(signal));
+ $.ajax({
+ dataType: 'json',
+ url:'signal',
+ data: { token: sessionToken, signal: JSON.stringify(signal) },
+ success: function(){
+ continuation();
+ },
+ error: function(reply){
+ console_log("Error: %o",reply);
+ }
+ });
+ }
+
+ // When the server creates elements, it assigns them a string "elid".
+ // This elidToElement function is used to sync the elids on the server with the
+ // elids on this client code. Lookups on elids that do not already exist in the client
+ // table are created and added automatically.
+ function elidToElement(elid){
+ if(elid == 'body')
+ return document.body;
+ else if(elid == 'head')
+ return document.head;
+ else if(el_table[elid]){
+ return el_table[elid];
+ } else {
+ if(elid[0] == '*'){
+ var create = elid.split(':');
+ var element = document.createElement(create[1]);
+ element.elid = elid;
+ el_table[elid] = element;
+ return element;
+ } else {
+ throw "Unknown element: " + elid;
+ }
+ }
+ }
+ function deleteElementTable(elid){
+ delete el_table[elid];
+ }
+
+ // Get/generate a elid for an element. This function is used for cases in which the
+ // element is accessed without knowing an elid from the server, such as when the
+ // element is retrieved by type or html ID attribute. The element is then added to
+ // elid lookup table using the new elid.
+ // Note: The mapping between elids and DOM elements must be bijective.
+ function elementToElid(element){
+ if(element.elid) {
+ return element.elid;
+ }
+ else if (element === document.body) {
+ return "body";
+ }
+ else if (element === document.head) {
+ return "head";
+ }
+ else {
+ var elid = "!" + element_count.toString();
+ element_count++;
+ element.elid = elid;
+ el_table[elid] = element;
+ return elid;
+ }
+ }
+
+ // A log
+ function console_log(){
+ if (tp_enable_log) {
+ window.console.log.apply(window.console,arguments);
+ }
+ };
+
+})();
diff --git a/src/Graphics/UI/index.html b/src/Graphics/UI/index.html
new file mode 100644
--- /dev/null
+++ b/src/Graphics/UI/index.html
@@ -0,0 +1,10 @@
+
+
+
+
+
+
+
+
+
+