module Graphics.UI.Threepenny.Internal (
Window, disconnect,
startGUI,
UI, runUI, liftIOLater, askWindow,
FFI, FromJS, ToJS, JSFunction, JSObject, ffi,
runFunction, callFunction, ffiExport, debug, timestamp,
Element, fromJSObject, getWindow,
mkElementNamespace, mkElement, delete, appendChild, clearChildren,
EventData, domEvent, unsafeFromJSON,
) where
import Control.Applicative (Applicative)
import Control.Monad
import Control.Monad.Fix
import Control.Monad.IO.Class
import qualified Control.Monad.Trans.RWS.Lazy as Monad
import Data.Dynamic (Typeable)
import qualified Data.Aeson as JSON
import qualified Foreign.JavaScript as JS
import qualified Foreign.RemotePtr as Foreign
import qualified Reactive.Threepenny as E
import Foreign.JavaScript hiding (runFunction, callFunction, debug, timestamp, Window)
data Window = Window
{ jsWindow :: JS.Window
, eDisconnect :: E.Event ()
, wEvents :: Foreign.Vendor Events
, wChildren :: Foreign.Vendor ()
}
startGUI
:: Config
-> (Window -> UI ())
-> IO ()
startGUI config init = JS.serve config $ \w -> do
(eDisconnect, handleDisconnect) <- E.newEvent
JS.onDisconnect w $ handleDisconnect ()
wEvents <- Foreign.newVendor
wChildren <- Foreign.newVendor
let window = Window
{ jsWindow = w
, eDisconnect = eDisconnect
, wEvents = wEvents
, wChildren = wChildren
}
runUI window $ init window
disconnect :: Window -> E.Event ()
disconnect = eDisconnect
type Events = String -> E.Event JSON.Value
type Children = Foreign.RemotePtr ()
data Element = Element
{ toJSObject :: JS.JSObject
, elEvents :: Events
, elChildren :: Children
, elWindow :: Window
} deriving (Typeable)
instance ToJS Element where
render = render . toJSObject
getWindow :: Element -> IO Window
getWindow = return . elWindow
getChildren :: JS.JSObject -> Window -> IO Children
getChildren el window@Window{ wChildren = wChildren } =
Foreign.withRemotePtr el $ \coupon _ -> do
mptr <- Foreign.lookup coupon wChildren
case mptr of
Nothing -> do
ptr <- Foreign.newRemotePtr coupon () wChildren
Foreign.addReachable el ptr
return ptr
Just p ->
return p
fromJSObject0 :: JS.JSObject -> Window -> IO Element
fromJSObject0 el window = do
events <- getEvents el window
children <- getChildren el window
return $ Element el events children window
fromJSObject :: JS.JSObject -> UI Element
fromJSObject el = do
window <- askWindow
liftIO $ do
Foreign.addReachable (JS.root $ jsWindow window) el
fromJSObject0 el window
addEvents :: JS.JSObject -> Window -> IO Events
addEvents el Window{ jsWindow = w, wEvents = wEvents } = do
let initializeEvent (name,_,handler) = do
handlerPtr <- JS.exportHandler w handler
Foreign.addReachable el handlerPtr
JS.runFunction w $
ffi "Haskell.bind(%1,%2,%3)" el name handlerPtr
events <- E.newEventsNamed initializeEvent
Foreign.withRemotePtr el $ \coupon _ -> do
ptr <- Foreign.newRemotePtr coupon events wEvents
Foreign.addReachable el ptr
return events
getEvents :: JS.JSObject -> Window -> IO Events
getEvents el window@Window{ wEvents = wEvents } = do
Foreign.withRemotePtr el $ \coupon _ -> do
mptr <- Foreign.lookup coupon wEvents
case mptr of
Nothing -> addEvents el window
Just p -> Foreign.withRemotePtr p $ \_ -> return
type EventData = JSON.Value
unsafeFromJSON :: JSON.FromJSON a => EventData -> a
unsafeFromJSON x = let JSON.Success y = JSON.fromJSON x in y
domEvent
:: String
-> Element
-> E.Event EventData
domEvent name el = elEvents el name
mkElement :: String -> UI Element
mkElement = mkElementNamespace Nothing
mkElementNamespace :: Maybe String -> String -> UI Element
mkElementNamespace namespace tag = do
window <- askWindow
let w = jsWindow window
liftIO $ do
el <- JS.unsafeCreateJSObject w $ case namespace of
Nothing -> ffi "document.createElement(%1)" tag
Just ns -> ffi "document.createElementNS(%1,%2)" ns tag
fromJSObject0 el window
delete :: Element -> UI ()
delete el = liftJSWindow $ \w -> do
JS.runFunction w $ ffi "$(%1).detach()" el
Foreign.destroy $ toJSObject el
clearChildren :: Element -> UI ()
clearChildren element = liftJSWindow $ \w -> do
let el = toJSObject element
Foreign.withRemotePtr el $ \_ _ -> do
JS.runFunction w $ ffi "$(%1).contents().detach()" el
Foreign.clearReachable (elChildren element)
appendChild :: Element -> Element -> UI ()
appendChild parent child = liftJSWindow $ \w -> do
Foreign.addReachable (elChildren parent) (toJSObject child)
JS.runFunction w $ ffi "$(%1).append($(%2))" (toJSObject parent) (toJSObject child)
newtype UI a = UI { unUI :: Monad.RWST Window [IO ()] () IO a }
deriving (Typeable)
liftJSWindow :: (JS.Window -> IO a) -> UI a
liftJSWindow f = askWindow >>= liftIO . f . jsWindow
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]
runFunction :: JSFunction () -> UI ()
runFunction fun = liftJSWindow $ \w -> JS.runFunction w fun
callFunction :: JSFunction a -> UI a
callFunction fun = liftJSWindow $ \w -> JS.callFunction w fun
ffiExport :: JS.IsHandler a => a -> UI JSObject
ffiExport fun = liftJSWindow $ \w -> do
handlerPtr <- JS.exportHandler w fun
Foreign.addReachable (JS.root w) handlerPtr
return handlerPtr
debug :: String -> UI ()
debug s = liftJSWindow $ \w -> JS.debug w s
timestamp :: UI ()
timestamp = liftJSWindow JS.timestamp