module Graphics.UI.Threepenny.Internal (
Window, disconnect,
startGUI,
UI, runUI, liftIOLater, askWindow,
FFI, FromJS, ToJS, JSFunction, JSObject, ffi,
runFunction, callFunction, ffiExport, debug,
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, Window)
data Window = Window
{ jsWindow :: JS.Window
, eDisconnect :: E.Event ()
, wEvents :: Foreign.Vendor Events
}
startGUI
:: Config
-> (Window -> UI ())
-> IO ()
startGUI config init = JS.serve config $ \w -> do
(eDisconnect, handleDisconnect) <- E.newEvent
JS.onDisconnect w $ handleDisconnect ()
wEvents <- Foreign.newVendor
let window = Window
{ jsWindow = w
, eDisconnect = eDisconnect
, wEvents = wEvents
}
runUI window $ init window
disconnect :: Window -> E.Event ()
disconnect = eDisconnect
type Events = String -> E.Event JSON.Value
data Element = Element
{ toJSObject :: JS.JSObject
, elEvents :: Events
, elWindow :: Window
} deriving (Typeable)
instance ToJS Element where
render = render . toJSObject
getWindow :: Element -> IO Window
getWindow = return . elWindow
fromJSObject :: JS.JSObject -> UI Element
fromJSObject el = do
window <- askWindow
liftIO $ do
Foreign.addReachable (JS.root $ jsWindow window) el
events <- getEvents el window
return $ Element el events 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.callFunction w $ case namespace of
Nothing -> ffi "document.createElement(%1)" tag
Just ns -> ffi "document.createElementNS(%1,%2)" ns tag
events <- getEvents el window
return $ Element el events 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 el _ _) = liftJSWindow $ \w -> do
Foreign.withRemotePtr el $ \_ _ -> do
JS.runFunction w $ ffi "$(%1).contents().detach()" el
appendChild :: Element -> Element -> UI ()
appendChild (Element eParent _ _) (Element eChild _ _) = liftJSWindow $ \w -> do
Foreign.addReachable eParent eChild
JS.runFunction w $ ffi "$(%1).append($(%2))" eParent eChild
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