module Graphics.UI.Threepenny.Core (
Config(..), defaultConfig, startGUI,
loadFile, loadDirectory,
UI, runUI, askWindow, liftIOLater,
module Control.Monad.IO.Class,
module Control.Monad.Fix,
Window, title, cookies, getRequestLocation,
Element, mkElement, getWindow, delete, (#+), string,
getHead, getBody,
children, text, html, attr, style, value,
getValuesList,
getElementsByTagName, getElementById, getElementsByClassName,
grid, row, column,
EventData(..), domEvent, disconnect, on, onEvent, onChanges,
module Reactive.Threepenny,
(#), (#.),
Attr, WriteAttr, ReadAttr, ReadWriteAttr(..),
set, sink, get, mkReadWriteAttr, mkWriteAttr, mkReadAttr,
bimapAttr, fromObjectProperty,
Widget(..), element, widget,
debug,
ToJS, FFI,
JSFunction, ffi, runFunction, callFunction,
HsFunction, ffiExport,
atomic,
fromJQueryProp, toElement,
audioPlay, audioStop,
) where
import Data.Dynamic
import Data.IORef
import qualified Data.Map as Map
import Data.Maybe (listToMaybe)
import Data.Functor
import Data.String (fromString)
import Control.Applicative (Applicative)
import Control.Concurrent.MVar
import Control.Monad
import Control.Monad.Fix
import Control.Monad.IO.Class
import qualified Control.Monad.Trans.RWS.Lazy as Monad
import Network.URI
import qualified Data.Aeson as JSON
import Reactive.Threepenny hiding (onChange)
import qualified Reactive.Threepenny as Reactive
import qualified Graphics.UI.Threepenny.Internal.Driver as Core
import Graphics.UI.Threepenny.Internal.Driver
( getRequestLocation
, atomic, )
import Graphics.UI.Threepenny.Internal.FFI
import Graphics.UI.Threepenny.Internal.Types as Core
( Window, Config, defaultConfig, Events, EventData
, ElementData(..), withElementData,)
import Graphics.UI.Threepenny.Internal.Types as Core
(unprotectedGetElementId, withElementData, ElementData(..))
startGUI
:: Config
-> (Window -> UI ())
-> IO ()
startGUI config handler = Core.serve config (\w -> runUI w $ handler w)
loadFile
:: String
-> FilePath
-> UI String
loadFile mime path = askWindow >>= \w -> liftIO $
Core.loadFile w (fromString mime) path
loadDirectory :: FilePath -> UI String
loadDirectory path = askWindow >>= \w -> liftIO $
Core.loadDirectory w path
newtype UI a = UI { unUI :: Monad.RWST Window [IO ()] () IO a }
deriving (Typeable)
instance Functor UI where
fmap f = UI . fmap f . unUI
instance Applicative UI where
pure = return
(<*>) = ap
instance Monad UI where
return = UI . return
m >>= k = UI $ unUI m >>= unUI . k
instance MonadIO UI where
liftIO = UI . liftIO
instance MonadFix UI where
mfix f = UI $ mfix (unUI . f)
runUI :: Window -> UI a -> IO a
runUI window m = do
(a, _, actions) <- Monad.runRWST (unUI m) window ()
sequence_ actions
return a
askWindow :: UI Window
askWindow = UI Monad.ask
liftIOLater :: IO () -> UI ()
liftIOLater x = UI $ Monad.tell [x]
title :: WriteAttr Window String
title = mkWriteAttr $ \s _ ->
runFunction $ ffi "document.title = %1;" s
cookies :: ReadAttr Window [(String,String)]
cookies = mkReadAttr (liftIO . Core.getRequestCookies)
data Element = Element { eEvents :: Core.Events, toElement :: Core.Element }
deriving (Typeable)
fromElement :: Core.Element -> IO Element
fromElement e = do
events <- Core.withElementData e $ \_ x -> return $ elEvents x
return $ Element events e
instance ToJS Element where
render = render . toElement
mkElement
:: String
-> UI Element
mkElement tag = mdo
let initializeEvent (name,_,handler) = Core.bind name el handler
events <- liftIO $ newEventsNamed initializeEvent
window <- askWindow
el <- liftIO $ Core.newElement window tag events
return $ Element events el
getWindow :: Element -> IO Window
getWindow e = Core.getWindow (toElement e)
delete :: Element -> UI ()
delete = liftIO . Core.delete . toElement
(#+) :: UI Element -> [UI Element] -> UI Element
(#+) mx mys = do
x <- mx
ys <- sequence mys
liftIO $ mapM_ (Core.appendElementTo (toElement x) . toElement) ys
return x
children :: WriteAttr Element [Element]
children = mkWriteAttr set
where
set xs x = liftIO $ do
Core.emptyEl $ toElement x
mapM_ (Core.appendElementTo (toElement x) . toElement) 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
getValuesList
:: [Element]
-> UI [String]
getValuesList = mapM (get value)
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 w = liftIO $ fromElement =<< Core.getHead w
getBody :: Window -> UI Element
getBody w = liftIO $ fromElement =<< Core.getBody w
getElementsByTagName
:: Window
-> String
-> UI [Element]
getElementsByTagName window name = liftIO $
mapM fromElement =<< Core.getElementsByTagName window name
getElementById
:: Window
-> String
-> UI (Maybe Element)
getElementById window id = liftIO $
fmap listToMaybe $ mapM fromElement =<< Core.getElementsById window [id]
getElementsByClassName
:: Window
-> String
-> UI [Element]
getElementsByClassName window cls = liftIO $
mapM fromElement =<< Core.getElementsByClassName window cls
runFunction :: JSFunction () -> UI ()
runFunction fun = do
window <- askWindow
liftIO $ Core.runFunction window fun
callFunction :: JSFunction a -> UI a
callFunction fun = do
window <- askWindow
liftIO $ Core.callFunction window fun
ffiExport :: IO () -> UI (HsFunction (IO ()))
ffiExport fun = do
window <- askWindow
liftIO $ Core.newHsFunction window fun
debug :: String -> UI ()
debug s = askWindow >>= \w -> liftIO $ Core.debug w s
audioPlay :: Element -> UI ()
audioPlay el = runFunction $ ffi "%1.play()" el
audioStop :: Element -> UI ()
audioStop el = runFunction $ ffi "prim_audio_stop(%1)" el
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
domEvent
:: String
-> Element
-> Event EventData
domEvent name (Element events _) = events name
disconnect :: Window -> Event ()
disconnect = Core.disconnect
on :: (element -> Event a) -> element -> (a -> UI void) -> UI ()
on f x = onEvent (f x)
onEvent :: Event a -> (a -> UI void) -> UI ()
onEvent e h = do
window <- askWindow
liftIO $ register e (void . runUI window . h)
return ()
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 :: (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