{-# LANGUAGE DeriveDataTypeable #-}
module Graphics.UI.Threepenny.Internal (
    -- * Synopsis
    -- | Internal core:
    -- 'UI' monad, integrating FRP and JavaScript FFI. garbage collection

    -- * Documentation
    Window, disconnect,
    startGUI, loadFile, loadDirectory,

    UI, runUI, MonadUI(..), liftIOLater, askWindow, liftJSWindow,

    FFI, FromJS, ToJS, JSFunction, JSObject, ffi,
    runFunction, callFunction,
    CallBufferMode(..), setCallBufferMode, flushCallBuffer,
    ffiExport, debug, timestamp,

    Element(toJSObject), fromJSObject, getWindow,
    mkElementNamespace, mkElement, delete, appendChild, clearChildren,

    EventData, domEvent, unsafeFromJSON,
    ) where

import           Control.Monad
import           Control.Monad.Catch
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 RB

import Foreign.JavaScript hiding
    (runFunction, callFunction, setCallBufferMode, flushCallBuffer
    ,debug, timestamp, Window, loadFile, loadDirectory)

{-----------------------------------------------------------------------------
    Custom Window type
------------------------------------------------------------------------------}
-- | The type 'Window' represents a browser window.
data Window = Window
    { Window -> Window
jsWindow    :: JS.Window  -- JavaScript window
    , Window -> Event ()
eDisconnect :: RB.Event () -- event that happens when client disconnects
    , Window -> Vendor Events
wEvents     :: Foreign.Vendor Events
                     -- events associated to 'Element's
    , Window -> Vendor ()
wChildren   :: Foreign.Vendor ()
                     -- children reachable from 'Element's
    }

-- | Start server for GUI sessions.
startGUI
    :: Config               -- ^ Server configuration.
    -> (Window -> UI ())    -- ^ Action to run whenever a client browser connects.
    -> IO ()
startGUI :: Config -> (Window -> UI ()) -> IO ()
startGUI Config
config Window -> UI ()
initialize = Config -> (Window -> IO ()) -> IO ()
JS.serve Config
config ((Window -> IO ()) -> IO ()) -> (Window -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Window
w -> do
    -- set up disconnect event
    (Event ()
eDisconnect, Handler ()
handleDisconnect) <- IO (Event (), Handler ())
forall a. IO (Event a, Handler a)
RB.newEvent
    Window -> IO () -> IO ()
JS.onDisconnect Window
w (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Handler ()
handleDisconnect ()

    -- make window
    Vendor Events
wEvents   <- IO (Vendor Events)
forall a. IO (Vendor a)
Foreign.newVendor
    Vendor ()
wChildren <- IO (Vendor ())
forall a. IO (Vendor a)
Foreign.newVendor
    let window :: Window
window = Window
            { jsWindow :: Window
jsWindow    = Window
w
            , eDisconnect :: Event ()
eDisconnect = Event ()
eDisconnect
            , wEvents :: Vendor Events
wEvents     = Vendor Events
wEvents
            , wChildren :: Vendor ()
wChildren   = Vendor ()
wChildren
            }

    -- run initialization
    Window -> UI () -> IO ()
forall a. Window -> UI a -> IO a
runUI Window
window (UI () -> IO ()) -> UI () -> IO ()
forall a b. (a -> b) -> a -> b
$ Window -> UI ()
initialize Window
window

-- | Event that occurs whenever the client has disconnected,
-- be it by closing the browser window or by exception.
--
-- Note: DOM Elements in a browser window that has been closed
-- can no longer be manipulated.
disconnect :: Window -> RB.Event ()
disconnect :: Window -> Event ()
disconnect = Window -> Event ()
eDisconnect

-- | Begin to serve a local file with a given 'MimeType' under a relative URI.
loadFile
    :: String    -- ^ MIME type
    -> FilePath  -- ^ Local path to the file
    -> UI String -- ^ Relative URI under which this file is now accessible
loadFile :: String -> String -> UI String
loadFile String
x String
y = (Window -> IO String) -> UI String
forall a. (Window -> IO a) -> UI a
liftJSWindow ((Window -> IO String) -> UI String)
-> (Window -> IO String) -> UI String
forall a b. (a -> b) -> a -> b
$ \Window
w -> Server -> String -> String -> IO String
JS.loadFile (Window -> Server
JS.getServer Window
w) String
x String
y

-- | Make a local directory available under a relative URI.
loadDirectory :: FilePath -> UI String
loadDirectory :: String -> UI String
loadDirectory String
x = (Window -> IO String) -> UI String
forall a. (Window -> IO a) -> UI a
liftJSWindow ((Window -> IO String) -> UI String)
-> (Window -> IO String) -> UI String
forall a b. (a -> b) -> a -> b
$ \Window
w -> Server -> String -> IO String
JS.loadDirectory (Window -> Server
JS.getServer Window
w) String
x

{-----------------------------------------------------------------------------
    Elements
------------------------------------------------------------------------------}
type Events = String -> RB.Event JSON.Value

-- Reachability information for children of an 'Element'.
-- The children of an element are always reachable from this RemotePtr.
type Children = Foreign.RemotePtr ()

data Element = Element
    { Element -> JSObject
toJSObject  :: JS.JSObject -- ^ Access to the primitive 'JS.JSObject' for roll-your-own foreign calls.
    , Element -> Events
elEvents    :: Events      -- ^ FRP event mapping
    , Element -> Children
elChildren  :: Children    -- ^ The children of this element
    , Element -> Window
elWindow    :: Window      -- ^ Window in which the element was created
    } deriving (Typeable)

instance ToJS Element where
    render :: Element -> IO JSCode
render = JSObject -> IO JSCode
forall a. ToJS a => a -> IO JSCode
render (JSObject -> IO JSCode)
-> (Element -> JSObject) -> Element -> IO JSCode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> JSObject
toJSObject

getWindow :: Element -> IO Window
getWindow :: Element -> IO Window
getWindow = Window -> IO Window
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Window -> IO Window)
-> (Element -> Window) -> Element -> IO Window
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> Window
elWindow

-- | Lookup or create reachability information for the children of
-- an element that is represented by a JavaScript object.
getChildren :: JS.JSObject -> Window -> IO Children
getChildren :: JSObject -> Window -> IO Children
getChildren JSObject
el Window{ wChildren :: Window -> Vendor ()
wChildren = Vendor ()
wChildren } =
    JSObject -> (Coupon -> JSPtr -> IO Children) -> IO Children
forall a b. RemotePtr a -> (Coupon -> a -> IO b) -> IO b
Foreign.withRemotePtr JSObject
el ((Coupon -> JSPtr -> IO Children) -> IO Children)
-> (Coupon -> JSPtr -> IO Children) -> IO Children
forall a b. (a -> b) -> a -> b
$ \Coupon
coupon JSPtr
_ -> do
        Maybe Children
mptr <- Coupon -> Vendor () -> IO (Maybe Children)
forall a. Coupon -> Vendor a -> IO (Maybe (RemotePtr a))
Foreign.lookup Coupon
coupon Vendor ()
wChildren
        case Maybe Children
mptr of
            Maybe Children
Nothing -> do
                -- Create new pointer for reachability information.
                Children
ptr <- Coupon -> () -> Vendor () -> IO Children
forall a. Coupon -> a -> Vendor a -> IO (RemotePtr a)
Foreign.newRemotePtr Coupon
coupon () Vendor ()
wChildren
                JSObject -> Children -> IO ()
forall a b. RemotePtr a -> RemotePtr b -> IO ()
Foreign.addReachable JSObject
el Children
ptr
                Children -> IO Children
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Children
ptr
            Just Children
p  ->
                -- Return existing information
                Children -> IO Children
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Children
p

-- | Convert JavaScript object into an Element by attaching relevant information.
-- The JavaScript object may still be subject to garbage collection.
fromJSObject0 :: JS.JSObject -> Window -> IO Element
fromJSObject0 :: JSObject -> Window -> IO Element
fromJSObject0 JSObject
el Window
window = do
    Events
events   <- JSObject -> Window -> IO Events
getEvents   JSObject
el Window
window
    Children
children <- JSObject -> Window -> IO Children
getChildren JSObject
el Window
window
    Element -> IO Element
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Element -> IO Element) -> Element -> IO Element
forall a b. (a -> b) -> a -> b
$ JSObject -> Events -> Children -> Window -> Element
Element JSObject
el Events
events Children
children Window
window

-- | Convert JavaScript object into an element.
--
-- FIXME: For the purpose of garbage collection, this element
-- will always be reachable from the root.
fromJSObject :: JS.JSObject -> UI Element
fromJSObject :: JSObject -> UI Element
fromJSObject JSObject
el = do
    Window
window <- UI Window
askWindow
    IO Element -> UI Element
forall a. IO a -> UI a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Element -> UI Element) -> IO Element -> UI Element
forall a b. (a -> b) -> a -> b
$ do
        Children -> JSObject -> IO ()
forall a b. RemotePtr a -> RemotePtr b -> IO ()
Foreign.addReachable (Window -> Children
JS.root (Window -> Children) -> Window -> Children
forall a b. (a -> b) -> a -> b
$ Window -> Window
jsWindow Window
window) JSObject
el
        JSObject -> Window -> IO Element
fromJSObject0 JSObject
el Window
window

-- | Add lazy FRP events to a JavaScript object.
addEvents :: JS.JSObject -> Window -> IO Events
addEvents :: JSObject -> Window -> IO Events
addEvents JSObject
el Window{ jsWindow :: Window -> Window
jsWindow = Window
w, wEvents :: Window -> Vendor Events
wEvents = Vendor Events
wEvents } = do
    -- Lazily create FRP events whenever they are needed.
    let initializeEvent :: (t, b, a) -> IO ()
initializeEvent (t
name,b
_,a
handler) = do
            JSObject
handlerPtr <- Window -> a -> IO JSObject
forall a. IsHandler a => Window -> a -> IO JSObject
JS.exportHandler Window
w a
handler
            -- make handler reachable from element
            JSObject -> JSObject -> IO ()
forall a b. RemotePtr a -> RemotePtr b -> IO ()
Foreign.addReachable JSObject
el JSObject
handlerPtr
            Window -> JSFunction () -> IO ()
JS.runFunction Window
w (JSFunction () -> IO ()) -> JSFunction () -> IO ()
forall a b. (a -> b) -> a -> b
$
                String -> JSObject -> t -> JSObject -> JSFunction ()
forall a. FFI a => String -> a
ffi String
"Haskell.on(%1,%2,%3)" JSObject
el t
name JSObject
handlerPtr

    Events
events <- Handler (String, Event Value, Handler Value) -> IO Events
forall name a.
Ord name =>
Handler (name, Event a, Handler a) -> IO (name -> Event a)
RB.newEventsNamed Handler (String, Event Value, Handler Value)
forall {a} {t} {b}. (IsHandler a, ToJS t) => (t, b, a) -> IO ()
initializeEvent

    -- Create new pointer and add reachability.
    JSObject -> (Coupon -> JSPtr -> IO ()) -> IO ()
forall a b. RemotePtr a -> (Coupon -> a -> IO b) -> IO b
Foreign.withRemotePtr JSObject
el ((Coupon -> JSPtr -> IO ()) -> IO ())
-> (Coupon -> JSPtr -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Coupon
coupon JSPtr
_ -> do
        RemotePtr Events
ptr <- Coupon -> Events -> Vendor Events -> IO (RemotePtr Events)
forall a. Coupon -> a -> Vendor a -> IO (RemotePtr a)
Foreign.newRemotePtr Coupon
coupon Events
events Vendor Events
wEvents
        JSObject -> RemotePtr Events -> IO ()
forall a b. RemotePtr a -> RemotePtr b -> IO ()
Foreign.addReachable JSObject
el RemotePtr Events
ptr

    Events -> IO Events
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Events
events

-- | Lookup or create lazy events for a JavaScript object.
getEvents :: JS.JSObject -> Window -> IO Events
getEvents :: JSObject -> Window -> IO Events
getEvents JSObject
el window :: Window
window@Window{ wEvents :: Window -> Vendor Events
wEvents = Vendor Events
wEvents } = do
    JSObject -> (Coupon -> JSPtr -> IO Events) -> IO Events
forall a b. RemotePtr a -> (Coupon -> a -> IO b) -> IO b
Foreign.withRemotePtr JSObject
el ((Coupon -> JSPtr -> IO Events) -> IO Events)
-> (Coupon -> JSPtr -> IO Events) -> IO Events
forall a b. (a -> b) -> a -> b
$ \Coupon
coupon JSPtr
_ -> do
        Maybe (RemotePtr Events)
mptr <- Coupon -> Vendor Events -> IO (Maybe (RemotePtr Events))
forall a. Coupon -> Vendor a -> IO (Maybe (RemotePtr a))
Foreign.lookup Coupon
coupon Vendor Events
wEvents
        case Maybe (RemotePtr Events)
mptr of
            Maybe (RemotePtr Events)
Nothing -> JSObject -> Window -> IO Events
addEvents JSObject
el Window
window
            Just RemotePtr Events
p  -> RemotePtr Events -> (Coupon -> Events -> IO Events) -> IO Events
forall a b. RemotePtr a -> (Coupon -> a -> IO b) -> IO b
Foreign.withRemotePtr RemotePtr Events
p ((Coupon -> Events -> IO Events) -> IO Events)
-> (Coupon -> Events -> IO Events) -> IO Events
forall a b. (a -> b) -> a -> b
$ \Coupon
_ -> Events -> IO Events
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return

-- | Events may carry data. At the moment, they may return
-- a single JSON value, as defined in the "Data.Aeson" module.
type EventData = JSON.Value

-- | Convert event data to a Haskell value.
-- Throws an exception when the data cannot be converted.
unsafeFromJSON :: JSON.FromJSON a => EventData -> a
unsafeFromJSON :: forall a. FromJSON a => Value -> a
unsafeFromJSON Value
x = let JSON.Success a
y = Value -> Result a
forall a. FromJSON a => Value -> Result a
JSON.fromJSON Value
x in a
y

-- | Obtain DOM event for a given element.
domEvent
    :: String
        -- ^ Event name. A full list can be found at
        --   <http://www.w3schools.com/jsref/dom_obj_event.asp>.
        --   Note that the @on@-prefix is not included,
        --   the name is @click@ and so on.
    -> Element          -- ^ Element where the event is to occur.
    -> RB.Event EventData
domEvent :: String -> Element -> Event Value
domEvent String
name Element
el = Element -> Events
elEvents Element
el String
name

-- | Make a new DOM element with a given tag name.
mkElement :: String -> UI Element
mkElement :: String -> UI Element
mkElement = Maybe String -> String -> UI Element
mkElementNamespace Maybe String
forall a. Maybe a
Nothing

-- | Make a new DOM element with a namespace and a given tag name.
--
-- A namespace 'Nothing' corresponds to the default HTML namespace.
mkElementNamespace :: Maybe String -> String -> UI Element
mkElementNamespace :: Maybe String -> String -> UI Element
mkElementNamespace Maybe String
namespace String
tag = do
    Window
window <- UI Window
askWindow
    let w :: Window
w = Window -> Window
jsWindow Window
window
    IO Element -> UI Element
forall a. IO a -> UI a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Element -> UI Element) -> IO Element -> UI Element
forall a b. (a -> b) -> a -> b
$ do
        JSObject
el <- Window -> JSFunction NewJSObject -> IO JSObject
JS.unsafeCreateJSObject Window
w (JSFunction NewJSObject -> IO JSObject)
-> JSFunction NewJSObject -> IO JSObject
forall a b. (a -> b) -> a -> b
$ case Maybe String
namespace of
            Maybe String
Nothing -> String -> String -> JSFunction NewJSObject
forall a. FFI a => String -> a
ffi String
"document.createElement(%1)" String
tag
            Just String
ns -> String -> String -> String -> JSFunction NewJSObject
forall a. FFI a => String -> a
ffi String
"document.createElementNS(%1,%2)" String
ns String
tag
        JSObject -> Window -> IO Element
fromJSObject0 JSObject
el Window
window

-- | Delete the given element.
--
-- This operation removes the element from the browser window DOM
-- and marks it for garbage collection on the Haskell side.
-- The element is unusable afterwards.
--
-- NOTE: If you wish to temporarily remove an element from the DOM tree,
-- change the 'children' property of its parent element instead.
delete :: Element -> UI ()
delete :: Element -> UI ()
delete Element
el = (Window -> IO ()) -> UI ()
forall a. (Window -> IO a) -> UI a
liftJSWindow ((Window -> IO ()) -> UI ()) -> (Window -> IO ()) -> UI ()
forall a b. (a -> b) -> a -> b
$ \Window
w -> do
    Window -> JSFunction () -> IO ()
JS.runFunction Window
w (JSFunction () -> IO ()) -> JSFunction () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Element -> JSFunction ()
forall a. FFI a => String -> a
ffi String
"$(%1).detach()" Element
el
    JSObject -> IO ()
forall a. RemotePtr a -> IO ()
Foreign.destroy (JSObject -> IO ()) -> JSObject -> IO ()
forall a b. (a -> b) -> a -> b
$ Element -> JSObject
toJSObject Element
el

-- | Remove all child elements.
clearChildren :: Element -> UI ()
clearChildren :: Element -> UI ()
clearChildren Element
element = (Window -> IO ()) -> UI ()
forall a. (Window -> IO a) -> UI a
liftJSWindow ((Window -> IO ()) -> UI ()) -> (Window -> IO ()) -> UI ()
forall a b. (a -> b) -> a -> b
$ \Window
w -> do
    let el :: JSObject
el = Element -> JSObject
toJSObject Element
element
    JSObject -> (Coupon -> JSPtr -> IO ()) -> IO ()
forall a b. RemotePtr a -> (Coupon -> a -> IO b) -> IO b
Foreign.withRemotePtr JSObject
el ((Coupon -> JSPtr -> IO ()) -> IO ())
-> (Coupon -> JSPtr -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Coupon
_ JSPtr
_ -> do
        -- Previous children are no longer reachable from this element
        Window -> JSFunction () -> IO ()
JS.runFunction Window
w (JSFunction () -> IO ()) -> JSFunction () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> JSObject -> JSFunction ()
forall a. FFI a => String -> a
ffi String
"$(%1).contents().detach()" JSObject
el
        Children -> IO ()
forall a. RemotePtr a -> IO ()
Foreign.clearReachable (Element -> Children
elChildren Element
element)

-- | Append a child element.
appendChild :: Element -> Element -> UI ()
appendChild :: Element -> Element -> UI ()
appendChild Element
parent Element
child = (Window -> IO ()) -> UI ()
forall a. (Window -> IO a) -> UI a
liftJSWindow ((Window -> IO ()) -> UI ()) -> (Window -> IO ()) -> UI ()
forall a b. (a -> b) -> a -> b
$ \Window
w -> do
    -- FIXME: We have to stop the child being reachable from its
    -- /previous/ parent.
    Children -> JSObject -> IO ()
forall a b. RemotePtr a -> RemotePtr b -> IO ()
Foreign.addReachable (Element -> Children
elChildren Element
parent) (Element -> JSObject
toJSObject Element
child)
    Window -> JSFunction () -> IO ()
JS.runFunction Window
w (JSFunction () -> IO ()) -> JSFunction () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> JSObject -> JSObject -> JSFunction ()
forall a. FFI a => String -> a
ffi String
"$(%1).append($(%2))" (Element -> JSObject
toJSObject Element
parent) (Element -> JSObject
toJSObject Element
child)


{-----------------------------------------------------------------------------
    UI monad
------------------------------------------------------------------------------}
{- |

User interface elements are created and manipulated in the 'UI' monad.

This monad is essentially just a thin wrapper around the familiar 'IO' monad.
Use the 'liftIO' function to access 'IO' operations like reading
and writing from files.

There are several subtle reasons why Threepenny
uses a custom 'UI' monad instead of the standard 'IO' monad:

* More convenience when calling JavaScript.
The monad keeps track of a browser 'Window' context
in which JavaScript function calls are executed.

* Recursion for functional reactive programming.

-}
newtype UI a = UI { forall a. UI a -> RWST Window [IO ()] () IO a
unUI :: Monad.RWST Window [IO ()] () IO a }
    deriving (Typeable)

class (Monad m) => MonadUI m where
    -- | Lift a computation from the 'UI' monad.
    liftUI :: UI a -> m a

instance MonadUI UI where
    liftUI :: forall a. UI a -> UI a
liftUI = UI a -> UI a
forall a. a -> a
id

-- | Access to the primitive 'JS.Window' object,
--   for roll-your-own JS foreign calls.
liftJSWindow :: (JS.Window -> IO a) -> UI a
liftJSWindow :: forall a. (Window -> IO a) -> UI a
liftJSWindow Window -> IO a
f = UI Window
askWindow UI Window -> (Window -> UI a) -> UI a
forall a b. UI a -> (a -> UI b) -> UI b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO a -> UI a
forall a. IO a -> UI a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> UI a) -> (Window -> IO a) -> Window -> UI a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Window -> IO a
f (Window -> IO a) -> (Window -> Window) -> Window -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Window -> Window
jsWindow

instance Functor UI where
    fmap :: forall a b. (a -> b) -> UI a -> UI b
fmap a -> b
f = RWST Window [IO ()] () IO b -> UI b
forall a. RWST Window [IO ()] () IO a -> UI a
UI (RWST Window [IO ()] () IO b -> UI b)
-> (UI a -> RWST Window [IO ()] () IO b) -> UI a -> UI b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> b)
-> RWST Window [IO ()] () IO a -> RWST Window [IO ()] () IO b
forall a b.
(a -> b)
-> RWST Window [IO ()] () IO a -> RWST Window [IO ()] () IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (RWST Window [IO ()] () IO a -> RWST Window [IO ()] () IO b)
-> (UI a -> RWST Window [IO ()] () IO a)
-> UI a
-> RWST Window [IO ()] () IO b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UI a -> RWST Window [IO ()] () IO a
forall a. UI a -> RWST Window [IO ()] () IO a
unUI

instance Applicative UI where
    pure :: forall a. a -> UI a
pure  = RWST Window [IO ()] () IO a -> UI a
forall a. RWST Window [IO ()] () IO a -> UI a
UI (RWST Window [IO ()] () IO a -> UI a)
-> (a -> RWST Window [IO ()] () IO a) -> a -> UI a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> RWST Window [IO ()] () IO a
forall a. a -> RWST Window [IO ()] () IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    <*> :: forall a b. UI (a -> b) -> UI a -> UI b
(<*>) = UI (a -> b) -> UI a -> UI b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad UI where
    return :: forall a. a -> UI a
return  = a -> UI a
forall a. a -> UI a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    UI a
m >>= :: forall a b. UI a -> (a -> UI b) -> UI b
>>= a -> UI b
k = RWST Window [IO ()] () IO b -> UI b
forall a. RWST Window [IO ()] () IO a -> UI a
UI (RWST Window [IO ()] () IO b -> UI b)
-> RWST Window [IO ()] () IO b -> UI b
forall a b. (a -> b) -> a -> b
$ UI a -> RWST Window [IO ()] () IO a
forall a. UI a -> RWST Window [IO ()] () IO a
unUI UI a
m RWST Window [IO ()] () IO a
-> (a -> RWST Window [IO ()] () IO b)
-> RWST Window [IO ()] () IO b
forall a b.
RWST Window [IO ()] () IO a
-> (a -> RWST Window [IO ()] () IO b)
-> RWST Window [IO ()] () IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= UI b -> RWST Window [IO ()] () IO b
forall a. UI a -> RWST Window [IO ()] () IO a
unUI (UI b -> RWST Window [IO ()] () IO b)
-> (a -> UI b) -> a -> RWST Window [IO ()] () IO b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> UI b
k

instance MonadIO UI where
    liftIO :: forall a. IO a -> UI a
liftIO = RWST Window [IO ()] () IO a -> UI a
forall a. RWST Window [IO ()] () IO a -> UI a
UI (RWST Window [IO ()] () IO a -> UI a)
-> (IO a -> RWST Window [IO ()] () IO a) -> IO a -> UI a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> RWST Window [IO ()] () IO a
forall a. IO a -> RWST Window [IO ()] () IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO

instance MonadFix UI where
    mfix :: forall a. (a -> UI a) -> UI a
mfix a -> UI a
f = RWST Window [IO ()] () IO a -> UI a
forall a. RWST Window [IO ()] () IO a -> UI a
UI (RWST Window [IO ()] () IO a -> UI a)
-> RWST Window [IO ()] () IO a -> UI a
forall a b. (a -> b) -> a -> b
$ (a -> RWST Window [IO ()] () IO a) -> RWST Window [IO ()] () IO a
forall a.
(a -> RWST Window [IO ()] () IO a) -> RWST Window [IO ()] () IO a
forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix (UI a -> RWST Window [IO ()] () IO a
forall a. UI a -> RWST Window [IO ()] () IO a
unUI (UI a -> RWST Window [IO ()] () IO a)
-> (a -> UI a) -> a -> RWST Window [IO ()] () IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> UI a
f)

instance MonadThrow UI where
    throwM :: forall e a. (HasCallStack, Exception e) => e -> UI a
throwM = RWST Window [IO ()] () IO a -> UI a
forall a. RWST Window [IO ()] () IO a -> UI a
UI (RWST Window [IO ()] () IO a -> UI a)
-> (e -> RWST Window [IO ()] () IO a) -> e -> UI a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> RWST Window [IO ()] () IO a
forall e a.
(HasCallStack, Exception e) =>
e -> RWST Window [IO ()] () IO a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM

instance MonadCatch UI where
    catch :: forall e a.
(HasCallStack, Exception e) =>
UI a -> (e -> UI a) -> UI a
catch UI a
m e -> UI a
f = RWST Window [IO ()] () IO a -> UI a
forall a. RWST Window [IO ()] () IO a -> UI a
UI (RWST Window [IO ()] () IO a -> UI a)
-> RWST Window [IO ()] () IO a -> UI a
forall a b. (a -> b) -> a -> b
$ RWST Window [IO ()] () IO a
-> (e -> RWST Window [IO ()] () IO a)
-> RWST Window [IO ()] () IO a
forall e a.
(HasCallStack, Exception e) =>
RWST Window [IO ()] () IO a
-> (e -> RWST Window [IO ()] () IO a)
-> RWST Window [IO ()] () IO a
forall (m :: * -> *) e a.
(MonadCatch m, HasCallStack, Exception e) =>
m a -> (e -> m a) -> m a
catch (UI a -> RWST Window [IO ()] () IO a
forall a. UI a -> RWST Window [IO ()] () IO a
unUI UI a
m) (UI a -> RWST Window [IO ()] () IO a
forall a. UI a -> RWST Window [IO ()] () IO a
unUI (UI a -> RWST Window [IO ()] () IO a)
-> (e -> UI a) -> e -> RWST Window [IO ()] () IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> UI a
f)

-- | Execute an 'UI' action in a particular browser window.
-- Also runs all scheduled 'IO' actions.
runUI :: Window -> UI a -> IO a
runUI :: forall a. Window -> UI a -> IO a
runUI Window
window UI a
m = do
    (a
a, ()
_, [IO ()]
actions) <- RWST Window [IO ()] () IO a -> Window -> () -> IO (a, (), [IO ()])
forall r w s (m :: * -> *) a.
RWST r w s m a -> r -> s -> m (a, s, w)
Monad.runRWST (UI a -> RWST Window [IO ()] () IO a
forall a. UI a -> RWST Window [IO ()] () IO a
unUI UI a
m) Window
window ()
    [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [IO ()]
actions
    a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a

-- | Retrieve current 'Window' context in the 'UI' monad.
askWindow :: UI Window
askWindow :: UI Window
askWindow = RWST Window [IO ()] () IO Window -> UI Window
forall a. RWST Window [IO ()] () IO a -> UI a
UI RWST Window [IO ()] () IO Window
forall w (m :: * -> *) r s. (Monoid w, Monad m) => RWST r w s m r
Monad.ask

-- | Schedule an 'IO' action to be run later.
liftIOLater :: IO () -> UI ()
liftIOLater :: IO () -> UI ()
liftIOLater IO ()
x = RWST Window [IO ()] () IO () -> UI ()
forall a. RWST Window [IO ()] () IO a -> UI a
UI (RWST Window [IO ()] () IO () -> UI ())
-> RWST Window [IO ()] () IO () -> UI ()
forall a b. (a -> b) -> a -> b
$ [IO ()] -> RWST Window [IO ()] () IO ()
forall (m :: * -> *) w r s. Monad m => w -> RWST r w s m ()
Monad.tell [IO ()
x]

{-----------------------------------------------------------------------------
    FFI
------------------------------------------------------------------------------}
-- | Run a JavaScript function, but do not wait for a result.
--
-- The client window uses JavaScript's @eval()@ function to run the code.
--
-- NOTE: The JavaScript function need not be executed immediately,
-- it can be buffered and sent to the browser window at a later time.
-- See 'setCallBufferMode' and 'flushCallBuffer' for more.
runFunction :: JSFunction () -> UI ()
runFunction :: JSFunction () -> UI ()
runFunction JSFunction ()
fun = (Window -> IO ()) -> UI ()
forall a. (Window -> IO a) -> UI a
liftJSWindow ((Window -> IO ()) -> UI ()) -> (Window -> IO ()) -> UI ()
forall a b. (a -> b) -> a -> b
$ \Window
w -> Window -> JSFunction () -> IO ()
JS.runFunction Window
w JSFunction ()
fun

-- | Call a JavaScript function and wait for the result.
--
-- The client window uses JavaScript's @eval()@ function to run the code.
callFunction :: JSFunction a -> UI a
callFunction :: forall a. JSFunction a -> UI a
callFunction JSFunction a
fun = (Window -> IO a) -> UI a
forall a. (Window -> IO a) -> UI a
liftJSWindow ((Window -> IO a) -> UI a) -> (Window -> IO a) -> UI a
forall a b. (a -> b) -> a -> b
$ \Window
w -> Window -> JSFunction a -> IO a
forall a. Window -> JSFunction a -> IO a
JS.callFunction Window
w JSFunction a
fun

-- | Set the call buffering mode for the browser window.
setCallBufferMode :: CallBufferMode -> UI ()
setCallBufferMode :: CallBufferMode -> UI ()
setCallBufferMode CallBufferMode
x = (Window -> IO ()) -> UI ()
forall a. (Window -> IO a) -> UI a
liftJSWindow ((Window -> IO ()) -> UI ()) -> (Window -> IO ()) -> UI ()
forall a b. (a -> b) -> a -> b
$ \Window
w -> Window -> CallBufferMode -> IO ()
JS.setCallBufferMode Window
w CallBufferMode
x

-- | Flush the call buffer,
-- i.e. send all outstanding JavaScript to the client in one single message.
flushCallBuffer :: UI ()
flushCallBuffer :: UI ()
flushCallBuffer = (Window -> IO ()) -> UI ()
forall a. (Window -> IO a) -> UI a
liftJSWindow ((Window -> IO ()) -> UI ()) -> (Window -> IO ()) -> UI ()
forall a b. (a -> b) -> a -> b
$ \Window
w -> Window -> IO ()
JS.flushCallBuffer Window
w

-- | Export the given Haskell function so that it can be called
-- from JavaScript code.
--
-- NOTE: At the moment, the 'JSObject' representing the exported function
-- will be referenced by the browser 'Window' in which it was created,
-- preventing garbage collection until this browser 'Window' is disconnected.
--
-- This makes it possible to use it as an event handler on the JavaScript side,
-- but it also means that the Haskell runtime has no way to detect
-- early when it is no longer needed.
--
-- In contrast, if you use the function 'domEvent' to register an
-- event handler to an 'Element',
-- then the handler will be garbage collected
-- as soon as the associated 'Element' is garbage collected.
ffiExport :: JS.IsHandler a => a -> UI JSObject
ffiExport :: forall a. IsHandler a => a -> UI JSObject
ffiExport a
fun = (Window -> IO JSObject) -> UI JSObject
forall a. (Window -> IO a) -> UI a
liftJSWindow ((Window -> IO JSObject) -> UI JSObject)
-> (Window -> IO JSObject) -> UI JSObject
forall a b. (a -> b) -> a -> b
$ \Window
w -> do
    JSObject
handlerPtr <- Window -> a -> IO JSObject
forall a. IsHandler a => Window -> a -> IO JSObject
JS.exportHandler Window
w a
fun
    Children -> JSObject -> IO ()
forall a b. RemotePtr a -> RemotePtr b -> IO ()
Foreign.addReachable (Window -> Children
JS.root Window
w) JSObject
handlerPtr
    JSObject -> IO JSObject
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return JSObject
handlerPtr

-- | Print a message on the client console if the client has debugging enabled.
debug :: String -> UI ()
debug :: String -> UI ()
debug String
s = (Window -> IO ()) -> UI ()
forall a. (Window -> IO a) -> UI a
liftJSWindow ((Window -> IO ()) -> UI ()) -> (Window -> IO ()) -> UI ()
forall a b. (a -> b) -> a -> b
$ \Window
w -> Window -> String -> IO ()
JS.debug Window
w String
s

-- | Print a timestamp and the difference to the previous timestamp
-- on the client console if the client has debugging enabled.
timestamp :: UI ()
timestamp :: UI ()
timestamp = (Window -> IO ()) -> UI ()
forall a. (Window -> IO a) -> UI a
liftJSWindow Window -> IO ()
JS.timestamp