module Graphics.UI.Threepenny.Core (
Config(..), defaultConfig, startGUI,
UI, runUI, askWindow, liftIOLater,
module Control.Monad.IO.Class,
module Control.Monad.Fix,
Window, title,
Element, getWindow, mkElement, mkElementNamespace, delete,
string,
getHead, getBody,
(#+), children, text, html, attr, style, value,
getElementsByTagName, getElementById, getElementsByClassName,
grid, row, column,
EventData, domEvent, unsafeFromJSON, disconnect, on, onEvent, onChanges,
module Reactive.Threepenny,
(#), (#.),
Attr, WriteAttr, ReadAttr, ReadWriteAttr(..),
set, sink, get, mkReadWriteAttr, mkWriteAttr, mkReadAttr,
bimapAttr, fromObjectProperty,
Widget(..), element, widget,
debug, timestamp,
ToJS, FFI,
JSFunction, ffi, runFunction, callFunction,
ffiExport,
fromJQueryProp,
) where
import Control.Monad (forM_, forM, void)
import Control.Monad.Fix
import Control.Monad.IO.Class
import qualified Data.Aeson as JSON
import qualified Foreign.JavaScript as JS
import qualified Graphics.UI.Threepenny.Internal as Core
import qualified Reactive.Threepenny as Reactive
import Foreign.JavaScript (Config(..), defaultConfig)
import Graphics.UI.Threepenny.Internal
import Reactive.Threepenny hiding (onChange)
title :: WriteAttr Window String
title = mkWriteAttr $ \s _ ->
runFunction $ ffi "document.title = %1;" s
(#+) :: UI Element -> [UI Element] -> UI Element
(#+) mx mys = do
x <- mx
ys <- sequence mys
mapM_ (Core.appendChild x) ys
return x
children :: WriteAttr Element [Element]
children = mkWriteAttr set
where
set xs x = do
Core.clearChildren x
mapM_ (Core.appendChild x) xs
html :: WriteAttr Element String
html = mkWriteAttr $ \s el ->
runFunction $ ffi "$(%1).html(%2)" el s
attr :: String -> WriteAttr Element String
attr name = mkWriteAttr $ \s el ->
runFunction $ ffi "$(%1).attr(%2,%3)" el name s
style :: WriteAttr Element [(String,String)]
style = mkWriteAttr $ \xs el -> forM_ xs $ \(name,val) ->
runFunction $ ffi "%1.style[%2] = %3" el name val
value :: Attr Element String
value = mkReadWriteAttr get set
where
get el = callFunction $ ffi "$(%1).val()" el
set v el = runFunction $ ffi "$(%1).val(%2)" el v
text :: WriteAttr Element String
text = mkWriteAttr $ \s el ->
runFunction $ ffi "$(%1).text(%2)" el s
string :: String -> UI Element
string s = mkElement "span" # set text s
getHead :: Window -> UI Element
getHead _ = fromJSObject =<< callFunction (ffi "document.head")
getBody :: Window -> UI Element
getBody _ = fromJSObject =<< callFunction (ffi "document.body")
getElementsByTagName
:: Window
-> String
-> UI [Element]
getElementsByTagName _ tag =
mapM fromJSObject =<< callFunction (ffi "document.getElementsByTagName(%1)" tag)
getElementById
:: Window
-> String
-> UI (Maybe Element)
getElementById _ id = do
x <- fromJSObject =<< callFunction (ffi "document.getElementById(%1)" id)
return $ Just x
getElementsByClassName
:: Window
-> String
-> UI [Element]
getElementsByClassName window s =
mapM fromJSObject =<< callFunction (ffi "document.getElementsByClassName(%1)" s)
row :: [UI Element] -> UI Element
row xs = grid [xs]
column :: [UI Element] -> UI Element
column = grid . map (:[])
grid :: [[UI Element]] -> UI 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
on :: (element -> Event a) -> element -> (a -> UI void) -> UI ()
on f x = void . onEvent (f x)
onEvent :: Event a -> (a -> UI void) -> UI (UI ())
onEvent e h = do
window <- askWindow
unregister <- liftIO $ register e (void . runUI window . h)
return (liftIO unregister)
onChanges :: Behavior a -> (a -> UI void) -> UI ()
onChanges b f = do
window <- askWindow
liftIO $ Reactive.onChange b (void . runUI window . f)
infixl 8 #
infixl 8 #+
infixl 8 #.
(#) :: a -> (a -> b) -> b
(#) = flip ($)
(#.) :: UI Element -> String -> UI Element
(#.) mx s = mx # set (attr "class") s
type Attr x a = ReadWriteAttr x a a
type ReadAttr x o = ReadWriteAttr x () o
type WriteAttr x i = ReadWriteAttr x i ()
data ReadWriteAttr x i o = ReadWriteAttr
{ get' :: x -> UI o
, set' :: i -> x -> UI ()
}
instance Functor (ReadWriteAttr x i) where
fmap f = bimapAttr id f
bimapAttr :: (i' -> i) -> (o -> o')
-> ReadWriteAttr x i o -> ReadWriteAttr x i' o'
bimapAttr from to attr = attr
{ get' = fmap to . get' attr
, set' = \i' -> set' attr (from i')
}
set :: ReadWriteAttr x i o -> i -> UI x -> UI x
set attr i mx = do { x <- mx; set' attr i x; return x; }
sink :: ReadWriteAttr x i o -> Behavior i -> UI x -> UI x
sink attr bi mx = do
x <- mx
window <- askWindow
liftIOLater $ do
i <- currentValue bi
runUI window $ set' attr i x
Reactive.onChange bi $ \i -> runUI window $ set' attr i x
return x
get :: ReadWriteAttr x i o -> x -> UI o
get attr = get' attr
mkReadWriteAttr
:: (x -> UI o)
-> (i -> x -> UI ())
-> ReadWriteAttr x i o
mkReadWriteAttr get set = ReadWriteAttr { get' = get, set' = set }
mkReadAttr :: (x -> UI o) -> ReadAttr x o
mkReadAttr get = mkReadWriteAttr get (\_ _ -> return ())
mkWriteAttr :: (i -> x -> UI ()) -> WriteAttr x i
mkWriteAttr set = mkReadWriteAttr (\_ -> return ()) set
fromJQueryProp :: String -> (JSON.Value -> a) -> (a -> JSON.Value) -> Attr Element a
fromJQueryProp name from to = mkReadWriteAttr get set
where
set v el = runFunction $ ffi "$(%1).prop(%2,%3)" el name (to v)
get el = fmap from $ callFunction $ ffi "$(%1).prop(%2)" el name
fromObjectProperty :: (FromJS a, ToJS a, FFI (JSFunction a)) => String -> Attr Element a
fromObjectProperty name = mkReadWriteAttr get set
where
set v el = runFunction $ ffi ("%1." ++ name ++ " = %2") el v
get el = callFunction $ ffi ("%1." ++ name) el
class Widget w where
getElement :: w -> Element
instance Widget Element where
getElement = id
element :: MonadIO m => Widget w => w -> m Element
element = return . getElement
widget :: Widget w => w -> UI w
widget = return