mirror of
https://github.com/ilyakooo0/reflex-dom.git
synced 2024-09-11 06:35:30 +03:00
Merge branch 'develop' into HEAD
# Conflicts: # default.nix # reflex-dom.cabal # src-ghc/Reflex/Dom/Xhr/Foreign.hs # src-ghcjs/Reflex/Dom/Xhr/Foreign.hs # src/Reflex/Dom/Class.hs # src/Reflex/Dom/Internal.hs # src/Reflex/Dom/Time.hs # src/Reflex/Dom/Widget/Basic.hs # src/Reflex/Dom/Xhr.hs
This commit is contained in:
Ryan Trinkle
parent
6f958965d8
commit
5903797631
@ -3,12 +3,12 @@
|
||||
, transformers, data-default, semigroups, aeson
|
||||
, ghc, webkitgtk3-javascriptcore, exception-transformers
|
||||
, webkitgtk24x, dependent-sum-template, bifunctors, zenc
|
||||
, random
|
||||
, random, raw-strings-qq
|
||||
}:
|
||||
|
||||
mkDerivation {
|
||||
pname = "reflex-dom";
|
||||
version = "0.2";
|
||||
version = "0.3";
|
||||
src = builtins.filterSource (path: type: baseNameOf path != ".git") ./.;
|
||||
buildDepends = [
|
||||
reflex
|
||||
@ -29,7 +29,7 @@ mkDerivation {
|
||||
bifunctors
|
||||
zenc
|
||||
random
|
||||
] ++ (if (ghc.pname or null) == "ghcjs" then [ ] else [ webkitgtk3-javascriptcore ]);
|
||||
] ++ (if (ghc.pname or null) == "ghcjs" then [ ] else [ webkitgtk3-javascriptcore raw-strings-qq ]);
|
||||
pkgconfigDepends = if (ghc.pname or null) == "ghcjs" then [ ] else [ webkitgtk24x ];
|
||||
license = null;
|
||||
}
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
Name: reflex-dom
|
||||
Version: 0.2
|
||||
Version: 0.3
|
||||
Synopsis: Functional Reactive Web Apps with Reflex
|
||||
Description: Reflex-DOM is a Functional Reactive web framework based on the Reflex FRP engine
|
||||
License: BSD3
|
||||
@ -15,24 +15,26 @@ extra-source-files: src-ghc/Reflex/Dom/Internal/Foreign.hs
|
||||
src-ghc/Reflex/Dom/Xhr/Foreign.hs
|
||||
src-ghcjs/Reflex/Dom/Internal/Foreign.hs
|
||||
src-ghcjs/Reflex/Dom/Xhr/Foreign.hs
|
||||
src/Reflex/Dom/Xhr/ResponseType.hs
|
||||
src/Reflex/Dom/Xhr/Exception.hs
|
||||
|
||||
library
|
||||
hs-source-dirs: src
|
||||
build-depends:
|
||||
base >= 4.7 && < 4.9,
|
||||
template-haskell,
|
||||
reflex == 0.3.*,
|
||||
dependent-sum == 0.2.*,
|
||||
dependent-map == 0.1.*,
|
||||
semigroups == 0.16.*,
|
||||
reflex == 0.4.*,
|
||||
dependent-sum == 0.3.*,
|
||||
dependent-map == 0.2.*,
|
||||
semigroups >= 0.16 && < 0.19,
|
||||
mtl >= 2.1 && < 2.3,
|
||||
containers == 0.5.*,
|
||||
these >= 0.4 && < 0.7,
|
||||
ref-tf == 0.4.*,
|
||||
random == 1.1.*,
|
||||
ghcjs-dom >= 0.2.1 && < 0.3,
|
||||
transformers == 0.3.* || == 0.4.*,
|
||||
lens >= 4.7 && < 4.14,
|
||||
ghcjs-dom >= 0.1.1.3 && < 0.2,
|
||||
safe == 0.3.*,
|
||||
text == 1.2.*,
|
||||
bytestring == 0.10.*,
|
||||
@ -43,11 +45,10 @@ library
|
||||
directory == 1.2.*,
|
||||
dependent-sum-template >= 0.0.0.4 && < 0.1,
|
||||
zenc == 0.1.*,
|
||||
bifunctors >= 4.2 && < 5.1
|
||||
bifunctors >= 4.2 && < 6
|
||||
|
||||
if impl(ghcjs)
|
||||
hs-source-dirs: src-ghcjs
|
||||
cpp-options: -D__GHCJS__
|
||||
build-depends:
|
||||
ghcjs-base,
|
||||
hashable == 1.2.*
|
||||
@ -55,11 +56,14 @@ library
|
||||
hs-source-dirs: src-ghc
|
||||
build-depends:
|
||||
glib == 0.13.*,
|
||||
gtk3 == 0.13.*,
|
||||
webkitgtk3 == 0.13.*,
|
||||
webkitgtk3-javascriptcore == 0.13.*
|
||||
gtk3 >= 0.13.0 && < 0.15,
|
||||
webkitgtk3 == 0.14.*,
|
||||
webkitgtk3-javascriptcore == 0.13.*,
|
||||
raw-strings-qq
|
||||
pkgconfig-depends:
|
||||
webkitgtk-3.0 >= 1.8
|
||||
if !os(windows)
|
||||
build-depends: unix == 2.7.*
|
||||
|
||||
exposed-modules:
|
||||
Reflex.Dom
|
||||
@ -80,9 +84,11 @@ library
|
||||
Reflex.Dom.Internal.Foreign
|
||||
Reflex.Dom.WebSocket.Foreign
|
||||
Reflex.Dom.Xhr.Foreign
|
||||
Reflex.Dom.Xhr.ResponseType
|
||||
Reflex.Dom.Xhr.Exception
|
||||
|
||||
other-extensions: TemplateHaskell
|
||||
ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2
|
||||
ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 -ferror-spans
|
||||
|
||||
source-repository head
|
||||
type: git
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
{-# LANGUAGE ForeignFunctionInterface #-}
|
||||
{-# LANGUAGE CPP, ForeignFunctionInterface, ScopedTypeVariables, LambdaCase #-}
|
||||
module Reflex.Dom.Internal.Foreign where
|
||||
|
||||
import Control.Lens hiding (set)
|
||||
@ -7,7 +7,7 @@ import Control.Concurrent
|
||||
import Control.Monad.State.Strict hiding (mapM, mapM_, forM, forM_, sequence, sequence_, get)
|
||||
import Foreign.Ptr
|
||||
import GHCJS.DOM.Navigator
|
||||
import GHCJS.DOM.DOMWindow
|
||||
import GHCJS.DOM.Window
|
||||
import Graphics.UI.Gtk hiding (Widget)
|
||||
import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSBase
|
||||
import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSObjectRef
|
||||
@ -15,7 +15,7 @@ import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSStringRef
|
||||
import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSValueRef
|
||||
import Graphics.UI.Gtk.WebKit.JavaScriptCore.WebFrame
|
||||
import Graphics.UI.Gtk.WebKit.WebView
|
||||
import Graphics.UI.Gtk.WebKit.Types hiding (Event, Widget, unWidget)
|
||||
import Graphics.UI.Gtk.WebKit.Types hiding (Event, Widget)
|
||||
import Graphics.UI.Gtk.WebKit.WebSettings
|
||||
import Graphics.UI.Gtk.WebKit.WebFrame
|
||||
import Graphics.UI.Gtk.WebKit.WebInspector
|
||||
@ -23,6 +23,21 @@ import Data.List
|
||||
import System.Directory
|
||||
import System.Glib.FFI hiding (void)
|
||||
|
||||
#ifndef mingw32_HOST_OS
|
||||
import System.Posix.Signals
|
||||
#endif
|
||||
|
||||
quitWebView :: WebView -> IO ()
|
||||
quitWebView wv = postGUIAsync $ do w <- widgetGetToplevel wv
|
||||
widgetDestroy w
|
||||
|
||||
installQuitHandler :: WebView -> IO ()
|
||||
#ifdef mingw32_HOST_OS
|
||||
installQuitHandler wv = return () -- TODO: Maybe figure something out here for Windows users.
|
||||
#else
|
||||
installQuitHandler wv = installHandler keyboardSignal (Catch (quitWebView wv)) Nothing >> return ()
|
||||
#endif
|
||||
|
||||
makeDefaultWebView :: String -> (WebView -> IO ()) -> IO ()
|
||||
makeDefaultWebView userAgentKey main = do
|
||||
_ <- initGUI
|
||||
@ -58,6 +73,7 @@ makeDefaultWebView userAgentKey main = do
|
||||
wf <- webViewGetMainFrame webView
|
||||
pwd <- getCurrentDirectory
|
||||
webFrameLoadString wf "" Nothing $ "file://" ++ pwd ++ "/"
|
||||
installQuitHandler webView
|
||||
mainGUI
|
||||
|
||||
runWebGUI :: (WebView -> IO ()) -> IO ()
|
||||
@ -70,8 +86,8 @@ runWebGUI' userAgentKey main = do
|
||||
case mbWindow of
|
||||
Just window -> do
|
||||
-- Check if we are running in javascript inside the the native version
|
||||
Just n <- domWindowGetNavigator window
|
||||
agent <- navigatorGetUserAgent n
|
||||
Just n <- getNavigator window
|
||||
agent <- getUserAgent n
|
||||
unless ((" " ++ userAgentKey) `isSuffixOf` agent) $ main (castToWebView window)
|
||||
Nothing -> do
|
||||
makeDefaultWebView userAgentKey main
|
||||
|
||||
@ -1,7 +1,8 @@
|
||||
{-# LANGUAGE ForeignFunctionInterface, TypeSynonymInstances, FlexibleInstances #-}
|
||||
module Reflex.Dom.Xhr.Foreign where
|
||||
{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, QuasiQuotes, ForeignFunctionInterface #-}
|
||||
module Reflex.Dom.Xhr.Foreign ( module Reflex.Dom.Xhr.Foreign
|
||||
, XhrResponseType
|
||||
) where
|
||||
|
||||
import Control.Lens.Indexed
|
||||
import qualified Data.Text as T
|
||||
import Data.Text (Text)
|
||||
import System.Glib.FFI
|
||||
@ -12,26 +13,33 @@ import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSStringRef
|
||||
import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSValueRef
|
||||
import Graphics.UI.Gtk.WebKit.JavaScriptCore.WebFrame
|
||||
import GHCJS.DOM.File
|
||||
import Reflex.Dom.Xhr.ResponseType
|
||||
import Reflex.Dom.Xhr.Exception
|
||||
import Control.Concurrent.MVar
|
||||
import Control.Exception.Base
|
||||
|
||||
import Reflex.Dom.Internal.Foreign
|
||||
|
||||
import Text.RawString.QQ
|
||||
|
||||
data XMLHttpRequest
|
||||
= XMLHttpRequest { xhrValue :: JSValueRef
|
||||
, xhrContext :: JSContextRef --TODO: Get rid of this
|
||||
}
|
||||
deriving (Eq, Ord)
|
||||
|
||||
responseTextToText :: Maybe String -> Maybe Text
|
||||
responseTextToText = fmap T.pack
|
||||
|
||||
statusTextToText :: String -> Text
|
||||
statusTextToText = T.pack
|
||||
data XhrResponseBody = XhrResponseBody { unXhrResponseBody :: JSValueRef }
|
||||
|
||||
stringToJSValue :: JSContextRef -> String -> IO JSValueRef
|
||||
stringToJSValue ctx s = jsvaluemakestring ctx =<< jsstringcreatewithutf8cstring s
|
||||
|
||||
toResponseType :: a -> a
|
||||
toResponseType = id
|
||||
toResponseType :: XhrResponseType -> String
|
||||
toResponseType XhrResponseType_Default = ""
|
||||
toResponseType XhrResponseType_ArrayBuffer = "arraybuffer"
|
||||
toResponseType XhrResponseType_Blob = "blob"
|
||||
toResponseType XhrResponseType_Document = "document"
|
||||
toResponseType XhrResponseType_JSON = "json"
|
||||
toResponseType XhrResponseType_Text = "text"
|
||||
|
||||
xmlHttpRequestNew :: WebView -> IO XMLHttpRequest
|
||||
xmlHttpRequestNew wv = do
|
||||
@ -75,7 +83,17 @@ xmlHttpRequestGetReadyState xhr = do
|
||||
d <- jsvaluetonumber c rs nullPtr
|
||||
return $ truncate d
|
||||
|
||||
xmlHttpRequestGetResponseText :: XMLHttpRequest -> IO (Maybe String)
|
||||
xmlHttpRequestGetResponse :: XMLHttpRequest -> IO (Maybe XhrResponseBody)
|
||||
xmlHttpRequestGetResponse xhr = do
|
||||
let c = xhrContext xhr
|
||||
script <- jsstringcreatewithutf8cstring "this.response"
|
||||
t <- jsevaluatescript c script (xhrValue xhr) nullPtr 1 nullPtr
|
||||
isNull <- jsvalueisnull c t
|
||||
case isNull of
|
||||
True -> return Nothing
|
||||
False -> return $ Just $ XhrResponseBody t
|
||||
|
||||
xmlHttpRequestGetResponseText :: XMLHttpRequest -> IO (Maybe Text)
|
||||
xmlHttpRequestGetResponseText xhr = do
|
||||
let c = xhrContext xhr
|
||||
script <- jsstringcreatewithutf8cstring "this.responseText"
|
||||
@ -89,7 +107,7 @@ xmlHttpRequestGetResponseText xhr = do
|
||||
s <- allocaBytes (fromIntegral l) $ \ps -> do
|
||||
_ <- jsstringgetutf8cstring'_ j ps (fromIntegral l)
|
||||
peekCString ps
|
||||
return $ Just s
|
||||
return $ Just $ T.pack s
|
||||
|
||||
class IsXhrPayload a where
|
||||
xmlHttpRequestSend :: XMLHttpRequest -> a -> IO ()
|
||||
@ -106,19 +124,56 @@ instance IsXhrPayload File where
|
||||
xmlHttpRequestSendPayload :: XMLHttpRequest -> Maybe String -> IO ()
|
||||
xmlHttpRequestSendPayload xhr payload = do
|
||||
let c = xhrContext xhr
|
||||
(o,s) <- case payload of
|
||||
Nothing -> do
|
||||
o <- toJSObject c [xhrValue xhr]
|
||||
s <- jsstringcreatewithutf8cstring "this[0].send();"
|
||||
return (o,s)
|
||||
Just payload' -> do
|
||||
d <- stringToJSValue c payload'
|
||||
o <- toJSObject c [xhrValue xhr, d]
|
||||
s <- jsstringcreatewithutf8cstring "this[0].send(this[1])"
|
||||
return (o,s)
|
||||
_ <- jsevaluatescript c s o nullPtr 1 nullPtr
|
||||
return ()
|
||||
|
||||
result <- newEmptyMVar
|
||||
let wrapper' x = wrapper $ \_ _ _ _ _ _ -> putMVar result x >> jsvaluemakeundefined c
|
||||
bracket (wrapper' $ Just XhrException_Aborted) freeHaskellFunPtr $ \a -> do
|
||||
onAbort <- jsobjectmakefunctionwithcallback c nullPtr a
|
||||
bracket (wrapper' $ Just XhrException_Error) freeHaskellFunPtr $ \e -> do
|
||||
onError <- jsobjectmakefunctionwithcallback c nullPtr e
|
||||
bracket (wrapper' Nothing) freeHaskellFunPtr $ \l -> do
|
||||
onLoad <- jsobjectmakefunctionwithcallback c nullPtr l
|
||||
(o,s) <- case payload of
|
||||
Nothing -> do
|
||||
d <- jsvaluemakeundefined c
|
||||
o <- toJSObject c [xhrValue xhr, d, onError, onAbort, onLoad]
|
||||
s <- jsstringcreatewithutf8cstring send
|
||||
return (o,s)
|
||||
Just payload' -> do
|
||||
d <- stringToJSValue c payload'
|
||||
o <- toJSObject c [xhrValue xhr, d, onError, onAbort, onLoad]
|
||||
s <- jsstringcreatewithutf8cstring send
|
||||
return (o,s)
|
||||
_ <- jsevaluatescript c s o nullPtr 1 nullPtr
|
||||
takeMVar result >>= mapM_ throwIO
|
||||
where
|
||||
send = [r|
|
||||
(function (xhr, d, onError, onAbort, onLoad) {
|
||||
var clear;
|
||||
var error = function () {
|
||||
clear(); onError();
|
||||
};
|
||||
var abort = function () {
|
||||
clear(); onAbort();
|
||||
};
|
||||
var load = function () {
|
||||
clear(); onLoad();
|
||||
};
|
||||
clear = function () {
|
||||
xhr.removeEventListener('error', error);
|
||||
xhr.removeEventListener('abort', abort);
|
||||
xhr.removeEventListener('load', load);
|
||||
}
|
||||
xhr.addEventListener('error', error);
|
||||
xhr.addEventListener('abort', abort);
|
||||
xhr.addEventListener('load', load);
|
||||
if(d) {
|
||||
xhr.send(d);
|
||||
} else {
|
||||
xhr.send();
|
||||
}
|
||||
})(this[0], this[1], this[2], this[3], this[4])
|
||||
|]
|
||||
|
||||
xmlHttpRequestSetRequestHeader :: XMLHttpRequest -> String -> String -> IO ()
|
||||
xmlHttpRequestSetRequestHeader xhr header value = do
|
||||
let c = xhrContext xhr
|
||||
@ -146,7 +201,7 @@ xmlHttpRequestGetStatus xhr = do
|
||||
d <- jsvaluetonumber c s nullPtr
|
||||
return $ truncate d
|
||||
|
||||
xmlHttpRequestGetStatusText :: XMLHttpRequest -> IO String
|
||||
xmlHttpRequestGetStatusText :: XMLHttpRequest -> IO Text
|
||||
xmlHttpRequestGetStatusText xhr = do
|
||||
let c = xhrContext xhr
|
||||
script <- jsstringcreatewithutf8cstring "this.statusText"
|
||||
@ -156,4 +211,4 @@ xmlHttpRequestGetStatusText xhr = do
|
||||
s <- allocaBytes (fromIntegral l) $ \ps -> do
|
||||
_ <- jsstringgetutf8cstring'_ j ps (fromIntegral l)
|
||||
peekCString ps
|
||||
return s
|
||||
return $ T.pack s
|
||||
|
||||
@ -1,29 +1,22 @@
|
||||
{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI, CPP #-}
|
||||
|
||||
module Reflex.Dom.Internal.Foreign ( runWebGUI
|
||||
, module Reflex.Dom.Internal.Foreign
|
||||
{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI #-}
|
||||
module Reflex.Dom.Internal.Foreign ( module Reflex.Dom.Internal.Foreign
|
||||
, runWebGUI
|
||||
) where
|
||||
|
||||
import Control.Monad
|
||||
import GHCJS.DOM
|
||||
import GHCJS.DOM.Types
|
||||
import GHCJS.Types
|
||||
import Data.Function
|
||||
import GHCJS.Foreign
|
||||
|
||||
#define JS(name, js, type) foreign import javascript unsafe js name :: type
|
||||
quitWebView :: WebView -> IO ()
|
||||
quitWebView = error "quitWebView: unimplemented in GHCJS"
|
||||
|
||||
instance Eq Node where
|
||||
(==) = eqRef `on` unNode
|
||||
|
||||
JS(getLocationHost_, "location.host", IO JSString)
|
||||
foreign import javascript unsafe "location['host']" getLocationHost_ :: IO JSString
|
||||
|
||||
getLocationHost :: FromJSString r => a -> IO r
|
||||
getLocationHost _ = liftM fromJSString getLocationHost_
|
||||
|
||||
JS(getLocationProtocol_, "location.protocol", IO JSString)
|
||||
foreign import javascript unsafe "location['protocol']" getLocationProtocol_ :: IO JSString
|
||||
|
||||
getLocationProtocol :: FromJSString r => a -> IO r
|
||||
getLocationProtocol _ = liftM fromJSString getLocationProtocol_
|
||||
|
||||
|
||||
|
||||
@ -1,44 +1,44 @@
|
||||
{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI, CPP, TemplateHaskell, NoMonomorphismRestriction, EmptyDataDecls, RankNTypes, GADTs, RecursiveDo, ScopedTypeVariables, FlexibleInstances, MultiParamTypeClasses, TypeFamilies, FlexibleContexts, DeriveDataTypeable, GeneralizedNewtypeDeriving, StandaloneDeriving, ConstraintKinds, UndecidableInstances, PolyKinds, AllowAmbiguousTypes #-}
|
||||
{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI, CPP #-}
|
||||
|
||||
module Reflex.Dom.WebSocket.Foreign where
|
||||
|
||||
import Prelude hiding (div, span, mapM, mapM_, concat, concatMap, all, sequence)
|
||||
|
||||
import Control.Monad hiding (forM, forM_, mapM, mapM_, sequence)
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.Text.Encoding
|
||||
import qualified Data.ByteString as BS
|
||||
import Foreign.Ptr
|
||||
import GHCJS.Foreign
|
||||
import GHCJS.Marshal
|
||||
import GHCJS.Types
|
||||
import GHCJS.DOM.EventM
|
||||
import GHCJS.DOM.WebSocket (message, open, closeEvent)
|
||||
import qualified GHCJS.DOM.WebSocket as GD
|
||||
import GHCJS.DOM.MessageEvent
|
||||
import GHCJS.DOM.EventM (on)
|
||||
import GHCJS.DOM.Types
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Monad.Reader
|
||||
import GHCJS.Buffer
|
||||
import JavaScript.TypedArray.ArrayBuffer as JS
|
||||
import GHCJS.Marshal.Pure
|
||||
|
||||
#define JS(name, js, type) foreign import javascript unsafe js name :: type
|
||||
|
||||
newtype JSWebSocket = JSWebSocket { unJSWebSocket :: JSRef JSWebSocket }
|
||||
|
||||
data JSByteArray
|
||||
JS(extractByteArray, "new Uint8Array($1_1.buf, $1_2, $2)", Ptr a -> Int -> IO (JSRef JSByteArray))
|
||||
|
||||
JS(newWebSocket_, "(function() { var ws = new WebSocket($1); ws['binaryType'] = 'arraybuffer'; ws['onmessage'] = function(e){ $2(e['data']); }; ws['onopen'] = function(e){ $3(); }; ws['onclose'] = function(e){ $4(); }; return ws; })()", JSString -> JSFun (JSString -> IO ()) -> JSFun (IO ()) -> JSFun (IO ()) -> IO (JSRef JSWebSocket))
|
||||
|
||||
JS(webSocketSend_, "$1['send'](String.fromCharCode.apply(null, $2))", JSRef JSWebSocket -> JSRef JSByteArray -> IO ())
|
||||
|
||||
webSocketSend :: JSWebSocket -> ByteString -> IO ()
|
||||
webSocketSend ws bs = BS.useAsCString bs $ \cStr -> do
|
||||
ba <- extractByteArray cStr $ BS.length bs
|
||||
webSocketSend_ (unJSWebSocket ws) ba
|
||||
data JSWebSocket = JSWebSocket { unWebSocket :: WebSocket }
|
||||
|
||||
newWebSocket :: a -> String -> (ByteString -> IO ()) -> IO () -> IO () -> IO JSWebSocket
|
||||
newWebSocket _ url onMessage onOpen onClose = do
|
||||
onMessageFun <- syncCallback1 AlwaysRetain True $ onMessage <=< return . encodeUtf8 . fromJSString
|
||||
rec onCloseFun <- syncCallback AlwaysRetain True $ do
|
||||
release onMessageFun
|
||||
release onCloseFun
|
||||
onClose
|
||||
onOpenFun <- syncCallback AlwaysRetain True $ do
|
||||
release onOpenFun
|
||||
onOpen
|
||||
liftM JSWebSocket $ newWebSocket_ (toJSString url) onMessageFun onOpenFun onCloseFun
|
||||
ws <- GD.newWebSocket url (Just [] :: Maybe [String])
|
||||
_ <- on ws open $ liftIO onOpen
|
||||
GD.setBinaryType ws "arraybuffer"
|
||||
_ <- on ws message $ do
|
||||
e <- ask
|
||||
d <- getData e
|
||||
ab <- liftIO $ unsafeFreeze $ pFromJSVal d
|
||||
liftIO $ onMessage $ toByteString 0 Nothing $ createFromArrayBuffer ab
|
||||
_ <- on ws closeEvent $ liftIO onClose
|
||||
return $ JSWebSocket ws
|
||||
|
||||
webSocketSend :: JSWebSocket -> ByteString -> IO ()
|
||||
webSocketSend (JSWebSocket ws) bs = do
|
||||
let (b, off, len) = fromByteString bs
|
||||
ab <- ArrayBuffer <$> if BS.length bs == 0 --TODO: remove this logic when https://github.com/ghcjs/ghcjs-base/issues/49 is fixed
|
||||
then jsval . getArrayBuffer <$> create 0
|
||||
else return $ js_dataView off len $ jsval $ getArrayBuffer b
|
||||
GD.send ws $ Just ab
|
||||
|
||||
foreign import javascript safe "new DataView($3,$1,$2)" js_dataView :: Int -> Int -> JSVal -> JSVal
|
||||
|
||||
@ -1,406 +1,160 @@
|
||||
{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI, FlexibleInstances #-}
|
||||
{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI, OverloadedStrings, FlexibleInstances #-}
|
||||
|
||||
module Reflex.Dom.Xhr.Foreign where
|
||||
module Reflex.Dom.Xhr.Foreign (
|
||||
XMLHttpRequest
|
||||
, XMLHttpRequestResponseType(..)
|
||||
, module Reflex.Dom.Xhr.Foreign
|
||||
) where
|
||||
|
||||
import GHCJS.Types
|
||||
import GHCJS.Foreign
|
||||
import GHCJS.Marshal
|
||||
import qualified Data.Text as T
|
||||
import Prelude hiding (error)
|
||||
import Data.Text (Text)
|
||||
import GHCJS.DOM.Types hiding (Text)
|
||||
import GHCJS.DOM.EventM
|
||||
import GHCJS.DOM
|
||||
import Data.Function
|
||||
import Control.Monad
|
||||
import GHCJS.DOM.Enums
|
||||
import GHCJS.DOM.XMLHttpRequest
|
||||
import Data.Maybe (fromMaybe)
|
||||
import GHCJS.DOM.EventTarget (dispatchEvent)
|
||||
import GHCJS.Types
|
||||
import Reflex.Dom.Xhr.Exception
|
||||
import Reflex.Dom.Xhr.ResponseType
|
||||
import Control.Exception (catch, throwIO)
|
||||
|
||||
data XhrResponseBody = XhrResponseBody { unXhrResponseBody :: JSVal }
|
||||
|
||||
prepareWebView :: WebView -> IO ()
|
||||
prepareWebView _ = return ()
|
||||
|
||||
foreign import javascript unsafe "h$isInstanceOf $1 $2"
|
||||
typeInstanceIsA' :: JSRef a -> JSRef GType -> Bool
|
||||
|
||||
typeInstanceIsA :: JSRef a -> GType -> Bool
|
||||
typeInstanceIsA o (GType t) = typeInstanceIsA' o t
|
||||
|
||||
castTo :: (GObjectClass obj, GObjectClass obj') => GType -> String
|
||||
-> (obj -> obj')
|
||||
castTo gtype objTypeName obj =
|
||||
case toGObject obj of
|
||||
gobj@(GObject objRef)
|
||||
| typeInstanceIsA objRef gtype
|
||||
-> unsafeCastGObject gobj
|
||||
| otherwise -> error $ "Cannot cast object to " ++ objTypeName
|
||||
|
||||
newtype XMLHttpRequest = XMLHttpRequest { unXMLHttpRequest :: JSRef XMLHttpRequest }
|
||||
|
||||
instance Eq XMLHttpRequest where
|
||||
(==) = eqRef `on` unXMLHttpRequest
|
||||
|
||||
instance ToJSRef XMLHttpRequest where
|
||||
toJSRef = return . unXMLHttpRequest
|
||||
{-# INLINE toJSRef #-}
|
||||
|
||||
instance FromJSRef XMLHttpRequest where
|
||||
fromJSRef = return . fmap XMLHttpRequest . maybeJSNull
|
||||
{-# INLINE fromJSRef #-}
|
||||
|
||||
class GObjectClass o => IsXMLHttpRequest o
|
||||
toXMLHttpRequest :: IsXMLHttpRequest o => o -> XMLHttpRequest
|
||||
toXMLHttpRequest = unsafeCastGObject . toGObject
|
||||
|
||||
instance IsXMLHttpRequest XMLHttpRequest
|
||||
instance GObjectClass XMLHttpRequest where
|
||||
toGObject = GObject . castRef . unXMLHttpRequest
|
||||
unsafeCastGObject = XMLHttpRequest . castRef . unGObject
|
||||
|
||||
castToXMLHttpRequest :: GObjectClass obj => obj -> XMLHttpRequest
|
||||
castToXMLHttpRequest = castTo gTypeXMLHttpRequest "XMLHttpRequest"
|
||||
|
||||
foreign import javascript unsafe "window[\"XMLHttpRequest\"]" gTypeXMLHttpRequest' :: JSRef GType
|
||||
gTypeXMLHttpRequest :: GType
|
||||
gTypeXMLHttpRequest = GType gTypeXMLHttpRequest'
|
||||
|
||||
|
||||
newtype XMLHttpRequestUpload = XMLHttpRequestUpload { unXMLHttpRequestUpload :: JSRef XMLHttpRequestUpload }
|
||||
|
||||
instance Eq XMLHttpRequestUpload where
|
||||
(==) = eqRef `on` unXMLHttpRequestUpload
|
||||
|
||||
instance ToJSRef XMLHttpRequestUpload where
|
||||
toJSRef = return . unXMLHttpRequestUpload
|
||||
{-# INLINE toJSRef #-}
|
||||
|
||||
instance FromJSRef XMLHttpRequestUpload where
|
||||
fromJSRef = return . fmap XMLHttpRequestUpload . maybeJSNull
|
||||
{-# INLINE fromJSRef #-}
|
||||
|
||||
class GObjectClass o => IsXMLHttpRequestUpload o
|
||||
toXMLHttpRequestUpload :: IsXMLHttpRequestUpload o => o -> XMLHttpRequestUpload
|
||||
toXMLHttpRequestUpload = unsafeCastGObject . toGObject
|
||||
|
||||
instance IsXMLHttpRequestUpload XMLHttpRequestUpload
|
||||
instance GObjectClass XMLHttpRequestUpload where
|
||||
toGObject = GObject . castRef . unXMLHttpRequestUpload
|
||||
unsafeCastGObject = XMLHttpRequestUpload . castRef . unGObject
|
||||
|
||||
castToXMLHttpRequestUpload :: GObjectClass obj => obj -> XMLHttpRequestUpload
|
||||
castToXMLHttpRequestUpload = castTo gTypeXMLHttpRequestUpload "XMLHttpRequestUpload"
|
||||
|
||||
foreign import javascript unsafe "window[\"XMLHttpRequestUpload\"]" gTypeXMLHttpRequestUpload' :: JSRef GType
|
||||
gTypeXMLHttpRequestUpload :: GType
|
||||
gTypeXMLHttpRequestUpload = GType gTypeXMLHttpRequestUpload'
|
||||
|
||||
foreign import javascript unsafe "new XMLHttpRequest()"
|
||||
ghcjs_dom_xml_http_request_new ::
|
||||
IO (JSRef XMLHttpRequest)
|
||||
|
||||
xmlHttpRequestNew :: a -> IO XMLHttpRequest
|
||||
xmlHttpRequestNew _ = XMLHttpRequest <$> ghcjs_dom_xml_http_request_new
|
||||
|
||||
foreign import javascript unsafe "$1[\"open\"]($2, $3, $4, $5, $6)"
|
||||
ghcjs_dom_xml_http_request_open ::
|
||||
JSRef XMLHttpRequest -> JSString -> JSString -> JSBool -> JSString -> JSString -> IO ()
|
||||
xmlHttpRequestNew _ = newXMLHttpRequest
|
||||
|
||||
xmlHttpRequestOpen ::
|
||||
(IsXMLHttpRequest self, ToJSString method, ToJSString url, ToJSString user, ToJSString password) =>
|
||||
self -> method -> url -> Bool -> user -> password -> IO ()
|
||||
xmlHttpRequestOpen self method url async user password
|
||||
= ghcjs_dom_xml_http_request_open
|
||||
(unXMLHttpRequest (toXMLHttpRequest self))
|
||||
(toJSString method)
|
||||
(toJSString url)
|
||||
(toJSBool async)
|
||||
(toJSString user)
|
||||
(toJSString password)
|
||||
(ToJSString method, ToJSString url, ToJSString user, ToJSString password) =>
|
||||
XMLHttpRequest -> method -> url -> Bool -> user -> password -> IO ()
|
||||
xmlHttpRequestOpen = open
|
||||
|
||||
foreign import javascript unsafe "($2===null)?$1[\"send\"]():$1[\"send\"]($2)"
|
||||
ghcjs_dom_xml_http_request_send ::
|
||||
JSRef XMLHttpRequest -> JSRef XhrPayload -> IO ()
|
||||
|
||||
newtype XhrPayload = XhrPayload { unXhrPayload :: JSRef XhrPayload }
|
||||
convertException :: XHRError -> XhrException
|
||||
convertException e = case e of
|
||||
XHRError -> XhrException_Error
|
||||
XHRAborted -> XhrException_Aborted
|
||||
|
||||
class IsXhrPayload a where
|
||||
xmlHttpRequestSend :: IsXMLHttpRequest self => self -> a -> IO ()
|
||||
sendXhrPayload :: XMLHttpRequest -> a -> IO ()
|
||||
|
||||
instance IsXhrPayload () where
|
||||
xmlHttpRequestSend xhr _ = xmlHttpRequestSendPayload xhr $ XhrPayload jsNull
|
||||
sendXhrPayload xhr _ = send xhr
|
||||
|
||||
instance IsXhrPayload String where
|
||||
xmlHttpRequestSend xhr = xmlHttpRequestSendPayload xhr . XhrPayload . castRef . toJSString
|
||||
sendXhrPayload = sendString
|
||||
|
||||
foreign import javascript unsafe "$r = new FormData(); $r['append']($1, $2)" fileToFormData :: JSString -> JSRef File -> IO (JSRef XhrPayload)
|
||||
instance IsXhrPayload FormData where
|
||||
sendXhrPayload = sendFormData
|
||||
|
||||
instance IsXhrPayload File where
|
||||
xmlHttpRequestSend xhr = xmlHttpRequestSendPayload xhr . XhrPayload <=< fileToFormData (toJSString "file") . unFile
|
||||
instance IsXhrPayload Document where
|
||||
sendXhrPayload = sendDocument
|
||||
|
||||
xmlHttpRequestSendPayload :: IsXMLHttpRequest self => self -> XhrPayload -> IO ()
|
||||
xmlHttpRequestSendPayload self (XhrPayload p) = ghcjs_dom_xml_http_request_send (unXMLHttpRequest (toXMLHttpRequest self)) p
|
||||
instance IsXhrPayload Blob where
|
||||
sendXhrPayload = sendBlob
|
||||
|
||||
newtype XhrPayload = XhrPayload { unXhrPayload :: JSVal }
|
||||
|
||||
foreign import javascript unsafe "$1[\"setRequestHeader\"]($2, $3)"
|
||||
ghcjs_dom_xml_http_request_set_request_header ::
|
||||
JSRef XMLHttpRequest -> JSString -> JSString -> IO ()
|
||||
-- This used to be a non blocking call, but now it uses an interruptible ffi
|
||||
xmlHttpRequestSend :: IsXhrPayload payload => XMLHttpRequest -> payload -> IO ()
|
||||
xmlHttpRequestSend self p = sendXhrPayload self p `catch` (throwIO . convertException)
|
||||
|
||||
xmlHttpRequestSetRequestHeader ::
|
||||
(IsXMLHttpRequest self, ToJSString header, ToJSString value) =>
|
||||
self -> header -> value -> IO ()
|
||||
xmlHttpRequestSetRequestHeader self header value
|
||||
= ghcjs_dom_xml_http_request_set_request_header
|
||||
(unXMLHttpRequest (toXMLHttpRequest self))
|
||||
(toJSString header)
|
||||
(toJSString value)
|
||||
xmlHttpRequestSetRequestHeader :: (ToJSString header, ToJSString value)
|
||||
=> XMLHttpRequest -> header -> value -> IO ()
|
||||
xmlHttpRequestSetRequestHeader = setRequestHeader
|
||||
|
||||
foreign import javascript unsafe "$1[\"abort\"]()"
|
||||
ghcjs_dom_xml_http_request_abort :: JSRef XMLHttpRequest -> IO ()
|
||||
xmlHttpRequestAbort :: XMLHttpRequest -> IO ()
|
||||
xmlHttpRequestAbort = abort
|
||||
|
||||
xmlHttpRequestAbort :: (IsXMLHttpRequest self) => self -> IO ()
|
||||
xmlHttpRequestAbort self
|
||||
= ghcjs_dom_xml_http_request_abort
|
||||
(unXMLHttpRequest (toXMLHttpRequest self))
|
||||
xmlHttpRequestGetAllResponseHeaders :: XMLHttpRequest -> IO Text
|
||||
xmlHttpRequestGetAllResponseHeaders self = fromMaybe "" <$> getAllResponseHeaders self
|
||||
|
||||
foreign import javascript unsafe "$1[\"getAllResponseHeaders\"]()"
|
||||
ghcjs_dom_xml_http_request_get_all_response_headers ::
|
||||
JSRef XMLHttpRequest -> IO JSString
|
||||
xmlHttpRequestGetResponseHeader :: (ToJSString header)
|
||||
=> XMLHttpRequest -> header -> IO Text
|
||||
xmlHttpRequestGetResponseHeader self header = fromMaybe "" <$> getResponseHeader self header
|
||||
|
||||
xmlHttpRequestGetAllResponseHeaders ::
|
||||
(IsXMLHttpRequest self, FromJSString result) =>
|
||||
self -> IO result
|
||||
xmlHttpRequestGetAllResponseHeaders self
|
||||
= fromJSString <$>
|
||||
(ghcjs_dom_xml_http_request_get_all_response_headers
|
||||
(unXMLHttpRequest (toXMLHttpRequest self)))
|
||||
xmlHttpRequestOverrideMimeType :: ToJSString override => XMLHttpRequest -> override -> IO ()
|
||||
xmlHttpRequestOverrideMimeType = overrideMimeType
|
||||
|
||||
foreign import javascript unsafe "$1[\"getResponseHeader\"]($2)"
|
||||
ghcjs_dom_xml_http_request_get_response_header ::
|
||||
JSRef XMLHttpRequest -> JSString -> IO JSString
|
||||
xmlHttpRequestDispatchEvent :: IsEvent evt => XMLHttpRequest -> Maybe evt -> IO Bool
|
||||
xmlHttpRequestDispatchEvent = dispatchEvent
|
||||
|
||||
xmlHttpRequestGetResponseHeader ::
|
||||
(IsXMLHttpRequest self, ToJSString header, FromJSString result) =>
|
||||
self -> header -> IO result
|
||||
xmlHttpRequestGetResponseHeader self header
|
||||
= fromJSString <$>
|
||||
(ghcjs_dom_xml_http_request_get_response_header
|
||||
(unXMLHttpRequest (toXMLHttpRequest self))
|
||||
(toJSString header))
|
||||
xmlHttpRequestOnabort :: XMLHttpRequest -> EventM XMLHttpRequest XMLHttpRequestProgressEvent () -> IO (IO ())
|
||||
xmlHttpRequestOnabort = (`on` abortEvent)
|
||||
|
||||
foreign import javascript unsafe "$1[\"overrideMimeType\"]($2)"
|
||||
ghcjs_dom_xml_http_request_override_mime_type ::
|
||||
JSRef XMLHttpRequest -> JSString -> IO ()
|
||||
xmlHttpRequestOnerror :: XMLHttpRequest -> EventM XMLHttpRequest XMLHttpRequestProgressEvent () -> IO (IO ())
|
||||
xmlHttpRequestOnerror = (`on` error)
|
||||
|
||||
xmlHttpRequestOverrideMimeType ::
|
||||
(IsXMLHttpRequest self, ToJSString override) =>
|
||||
self -> override -> IO ()
|
||||
xmlHttpRequestOverrideMimeType self override
|
||||
= ghcjs_dom_xml_http_request_override_mime_type
|
||||
(unXMLHttpRequest (toXMLHttpRequest self))
|
||||
(toJSString override)
|
||||
xmlHttpRequestOnload :: XMLHttpRequest -> EventM XMLHttpRequest XMLHttpRequestProgressEvent () -> IO (IO ())
|
||||
xmlHttpRequestOnload = (`on` load)
|
||||
|
||||
foreign import javascript unsafe
|
||||
"($1[\"dispatchEvent\"]($2) ? 1 : 0)"
|
||||
ghcjs_dom_xml_http_request_dispatch_event ::
|
||||
JSRef XMLHttpRequest -> JSRef Event -> IO Bool
|
||||
xmlHttpRequestOnloadend :: XMLHttpRequest -> EventM XMLHttpRequest ProgressEvent () -> IO (IO ())
|
||||
xmlHttpRequestOnloadend = (`on` loadEnd)
|
||||
|
||||
xmlHttpRequestDispatchEvent ::
|
||||
(IsXMLHttpRequest self, IsEvent evt) =>
|
||||
self -> Maybe evt -> IO Bool
|
||||
xmlHttpRequestDispatchEvent self evt
|
||||
= ghcjs_dom_xml_http_request_dispatch_event
|
||||
(unXMLHttpRequest (toXMLHttpRequest self))
|
||||
(maybe jsNull (unEvent . toEvent) evt)
|
||||
xmlHttpRequestOnloadstart :: XMLHttpRequest -> EventM XMLHttpRequest ProgressEvent () -> IO (IO ())
|
||||
xmlHttpRequestOnloadstart = (`on` loadStart)
|
||||
|
||||
cUNSENT :: Integer
|
||||
cUNSENT = 0
|
||||
xmlHttpRequestOnprogress :: XMLHttpRequest -> EventM XMLHttpRequest XMLHttpRequestProgressEvent () -> IO (IO ())
|
||||
xmlHttpRequestOnprogress = (`on` progress)
|
||||
|
||||
cOPENED :: Integer
|
||||
cOPENED = 1
|
||||
xmlHttpRequestOntimeout :: XMLHttpRequest -> EventM XMLHttpRequest ProgressEvent () -> IO (IO ())
|
||||
xmlHttpRequestOntimeout = (`on` timeout)
|
||||
|
||||
cHEADERS_RECEIVED :: Integer
|
||||
cHEADERS_RECEIVED = 2
|
||||
xmlHttpRequestOnreadystatechange :: XMLHttpRequest -> EventM XMLHttpRequest Event () -> IO (IO ())
|
||||
xmlHttpRequestOnreadystatechange = (`on` readyStateChange)
|
||||
|
||||
cLOADING :: Integer
|
||||
cLOADING = 3
|
||||
xmlHttpRequestSetTimeout :: XMLHttpRequest -> Word -> IO ()
|
||||
xmlHttpRequestSetTimeout = setTimeout
|
||||
|
||||
cDONE :: Integer
|
||||
cDONE = 4
|
||||
xmlHttpRequestGetTimeout :: XMLHttpRequest -> IO Word
|
||||
xmlHttpRequestGetTimeout = getTimeout
|
||||
|
||||
xmlHttpRequestOnabort ::
|
||||
(IsXMLHttpRequest self) => Signal self (EventM UIEvent self ())
|
||||
xmlHttpRequestOnabort = (connect "abort")
|
||||
xmlHttpRequestGetReadyState :: XMLHttpRequest -> IO Word
|
||||
xmlHttpRequestGetReadyState = getReadyState
|
||||
|
||||
xmlHttpRequestOnerror ::
|
||||
(IsXMLHttpRequest self) => Signal self (EventM UIEvent self ())
|
||||
xmlHttpRequestOnerror = (connect "error")
|
||||
xmlHttpRequestSetWithCredentials :: XMLHttpRequest -> Bool -> IO ()
|
||||
xmlHttpRequestSetWithCredentials = setWithCredentials
|
||||
|
||||
xmlHttpRequestOnload ::
|
||||
(IsXMLHttpRequest self) => Signal self (EventM UIEvent self ())
|
||||
xmlHttpRequestOnload = (connect "load")
|
||||
xmlHttpRequestGetWithCredentials :: XMLHttpRequest -> IO Bool
|
||||
xmlHttpRequestGetWithCredentials = getWithCredentials
|
||||
|
||||
xmlHttpRequestOnloadend ::
|
||||
(IsXMLHttpRequest self) => Signal self (EventM UIEvent self ())
|
||||
xmlHttpRequestOnloadend = (connect "loadend")
|
||||
xmlHttpRequestGetUpload :: XMLHttpRequest -> IO (Maybe XMLHttpRequestUpload)
|
||||
xmlHttpRequestGetUpload = getUpload
|
||||
|
||||
xmlHttpRequestOnloadstart ::
|
||||
(IsXMLHttpRequest self) => Signal self (EventM UIEvent self ())
|
||||
xmlHttpRequestOnloadstart = (connect "loadstart")
|
||||
xmlHttpRequestGetResponseText :: FromJSString result => XMLHttpRequest -> IO (Maybe result)
|
||||
xmlHttpRequestGetResponseText = getResponseText
|
||||
|
||||
xmlHttpRequestOnprogress ::
|
||||
(IsXMLHttpRequest self) => Signal self (EventM UIEvent self ())
|
||||
xmlHttpRequestOnprogress = (connect "progress")
|
||||
xmlHttpRequestGetResponseXML :: XMLHttpRequest -> IO (Maybe Document)
|
||||
xmlHttpRequestGetResponseXML = getResponseXML
|
||||
|
||||
xmlHttpRequestOntimeout ::
|
||||
(IsXMLHttpRequest self) => Signal self (EventM UIEvent self ())
|
||||
xmlHttpRequestOntimeout = (connect "timeout")
|
||||
xmlHttpRequestSetResponseType :: XMLHttpRequest -> XMLHttpRequestResponseType -> IO ()
|
||||
xmlHttpRequestSetResponseType = setResponseType
|
||||
|
||||
xmlHttpRequestOnreadystatechange ::
|
||||
(IsXMLHttpRequest self) => Signal self (EventM UIEvent self ())
|
||||
xmlHttpRequestOnreadystatechange = (connect "readystatechange")
|
||||
toResponseType :: XhrResponseType -> XMLHttpRequestResponseType
|
||||
toResponseType XhrResponseType_Default = XMLHttpRequestResponseType
|
||||
toResponseType XhrResponseType_ArrayBuffer = XMLHttpRequestResponseTypeArraybuffer
|
||||
toResponseType XhrResponseType_Blob = XMLHttpRequestResponseTypeBlob
|
||||
toResponseType XhrResponseType_Document = XMLHttpRequestResponseTypeDocument
|
||||
toResponseType XhrResponseType_JSON = XMLHttpRequestResponseTypeJson
|
||||
toResponseType XhrResponseType_Text = XMLHttpRequestResponseTypeText
|
||||
|
||||
foreign import javascript unsafe "$1[\"timeout\"] = $2;"
|
||||
ghcjs_dom_xml_http_request_set_timeout ::
|
||||
JSRef XMLHttpRequest -> Word -> IO ()
|
||||
xmlHttpRequestGetResponseType :: XMLHttpRequest -> IO XMLHttpRequestResponseType
|
||||
xmlHttpRequestGetResponseType = getResponseType
|
||||
|
||||
xmlHttpRequestSetTimeout ::
|
||||
(IsXMLHttpRequest self) => self -> Word -> IO ()
|
||||
xmlHttpRequestSetTimeout self val
|
||||
= ghcjs_dom_xml_http_request_set_timeout
|
||||
(unXMLHttpRequest (toXMLHttpRequest self))
|
||||
val
|
||||
xmlHttpRequestGetStatus :: XMLHttpRequest -> IO Word
|
||||
xmlHttpRequestGetStatus = getStatus
|
||||
|
||||
foreign import javascript unsafe "$1[\"timeout\"]"
|
||||
ghcjs_dom_xml_http_request_get_timeout ::
|
||||
JSRef XMLHttpRequest -> IO Word
|
||||
xmlHttpRequestGetStatusText :: FromJSString result => XMLHttpRequest -> IO result
|
||||
xmlHttpRequestGetStatusText = getStatusText
|
||||
|
||||
xmlHttpRequestGetTimeout ::
|
||||
(IsXMLHttpRequest self) => self -> IO Word
|
||||
xmlHttpRequestGetTimeout self
|
||||
= ghcjs_dom_xml_http_request_get_timeout
|
||||
(unXMLHttpRequest (toXMLHttpRequest self))
|
||||
xmlHttpRequestGetResponseURL :: FromJSString result => XMLHttpRequest -> IO result
|
||||
xmlHttpRequestGetResponseURL = getResponseURL
|
||||
|
||||
foreign import javascript unsafe "$1[\"readyState\"]"
|
||||
ghcjs_dom_xml_http_request_get_ready_state ::
|
||||
JSRef XMLHttpRequest -> IO Word
|
||||
|
||||
xmlHttpRequestGetReadyState ::
|
||||
(IsXMLHttpRequest self) => self -> IO Word
|
||||
xmlHttpRequestGetReadyState self
|
||||
= ghcjs_dom_xml_http_request_get_ready_state
|
||||
(unXMLHttpRequest (toXMLHttpRequest self))
|
||||
|
||||
foreign import javascript unsafe "$1[\"withCredentials\"] = $2;"
|
||||
ghcjs_dom_xml_http_request_set_with_credentials ::
|
||||
JSRef XMLHttpRequest -> Bool -> IO ()
|
||||
|
||||
xmlHttpRequestSetWithCredentials ::
|
||||
(IsXMLHttpRequest self) => self -> Bool -> IO ()
|
||||
xmlHttpRequestSetWithCredentials self val
|
||||
= ghcjs_dom_xml_http_request_set_with_credentials
|
||||
(unXMLHttpRequest (toXMLHttpRequest self))
|
||||
val
|
||||
|
||||
foreign import javascript unsafe
|
||||
"($1[\"withCredentials\"] ? 1 : 0)"
|
||||
ghcjs_dom_xml_http_request_get_with_credentials ::
|
||||
JSRef XMLHttpRequest -> IO Bool
|
||||
|
||||
xmlHttpRequestGetWithCredentials ::
|
||||
(IsXMLHttpRequest self) => self -> IO Bool
|
||||
xmlHttpRequestGetWithCredentials self
|
||||
= ghcjs_dom_xml_http_request_get_with_credentials
|
||||
(unXMLHttpRequest (toXMLHttpRequest self))
|
||||
|
||||
foreign import javascript unsafe "$1[\"upload\"]"
|
||||
ghcjs_dom_xml_http_request_get_upload ::
|
||||
JSRef XMLHttpRequest -> IO (JSRef XMLHttpRequestUpload)
|
||||
|
||||
xmlHttpRequestGetUpload ::
|
||||
(IsXMLHttpRequest self) => self -> IO (Maybe XMLHttpRequestUpload)
|
||||
xmlHttpRequestGetUpload self
|
||||
= fmap XMLHttpRequestUpload . maybeJSNull <$>
|
||||
(ghcjs_dom_xml_http_request_get_upload
|
||||
(unXMLHttpRequest (toXMLHttpRequest self)))
|
||||
|
||||
foreign import javascript unsafe "$1[\"responseText\"]"
|
||||
ghcjs_dom_xml_http_request_get_response_text ::
|
||||
JSRef XMLHttpRequest -> IO JSString
|
||||
|
||||
xmlHttpRequestGetResponseText ::
|
||||
(IsXMLHttpRequest self, FromJSString result) => self -> IO (Maybe result)
|
||||
xmlHttpRequestGetResponseText self
|
||||
= fmap fromJSString . maybeJSNull <$>
|
||||
(ghcjs_dom_xml_http_request_get_response_text
|
||||
(unXMLHttpRequest (toXMLHttpRequest self)))
|
||||
|
||||
responseTextToText :: (Maybe JSString) -> Maybe Text
|
||||
responseTextToText r = fmap (T.pack . fromJSString) r
|
||||
|
||||
statusTextToText :: Text -> Text
|
||||
statusTextToText = id
|
||||
|
||||
foreign import javascript unsafe "$1[\"responseXML\"]"
|
||||
ghcjs_dom_xml_http_request_get_response_xml ::
|
||||
JSRef XMLHttpRequest -> IO (JSRef Document)
|
||||
|
||||
xmlHttpRequestGetResponseXML ::
|
||||
(IsXMLHttpRequest self) => self -> IO (Maybe Document)
|
||||
xmlHttpRequestGetResponseXML self
|
||||
= fmap Document . maybeJSNull <$>
|
||||
(ghcjs_dom_xml_http_request_get_response_xml
|
||||
(unXMLHttpRequest (toXMLHttpRequest self)))
|
||||
|
||||
foreign import javascript unsafe "$1[\"responseType\"] = $2;"
|
||||
ghcjs_dom_xml_http_request_set_response_type ::
|
||||
JSRef XMLHttpRequest -> JSString -> IO ()
|
||||
|
||||
xmlHttpRequestSetResponseType ::
|
||||
(IsXMLHttpRequest self, ToJSString val) => self -> val -> IO ()
|
||||
xmlHttpRequestSetResponseType self val
|
||||
= ghcjs_dom_xml_http_request_set_response_type
|
||||
(unXMLHttpRequest (toXMLHttpRequest self))
|
||||
(toJSString val)
|
||||
|
||||
toResponseType :: (ToJSString a) => a -> JSString
|
||||
toResponseType = toJSString
|
||||
|
||||
foreign import javascript unsafe "$1[\"responseType\"]"
|
||||
ghcjs_dom_xml_http_request_get_response_type ::
|
||||
JSRef XMLHttpRequest -> IO JSString
|
||||
|
||||
xmlHttpRequestGetResponseType ::
|
||||
(IsXMLHttpRequest self, FromJSString result) => self -> IO result
|
||||
xmlHttpRequestGetResponseType self
|
||||
= fromJSString <$>
|
||||
(ghcjs_dom_xml_http_request_get_response_type
|
||||
(unXMLHttpRequest (toXMLHttpRequest self)))
|
||||
|
||||
foreign import javascript unsafe "$1[\"status\"]"
|
||||
ghcjs_dom_xml_http_request_get_status ::
|
||||
JSRef XMLHttpRequest -> IO Word
|
||||
|
||||
xmlHttpRequestGetStatus ::
|
||||
(IsXMLHttpRequest self) => self -> IO Word
|
||||
xmlHttpRequestGetStatus self
|
||||
= ghcjs_dom_xml_http_request_get_status
|
||||
(unXMLHttpRequest (toXMLHttpRequest self))
|
||||
|
||||
foreign import javascript unsafe "$1[\"statusText\"]"
|
||||
ghcjs_dom_xml_http_request_get_status_text ::
|
||||
JSRef XMLHttpRequest -> IO JSString
|
||||
|
||||
xmlHttpRequestGetStatusText ::
|
||||
(IsXMLHttpRequest self, FromJSString result) => self -> IO result
|
||||
xmlHttpRequestGetStatusText self
|
||||
= fromJSString <$>
|
||||
(ghcjs_dom_xml_http_request_get_status_text
|
||||
(unXMLHttpRequest (toXMLHttpRequest self)))
|
||||
|
||||
foreign import javascript unsafe "$1[\"responseURL\"]"
|
||||
ghcjs_dom_xml_http_request_get_response_url ::
|
||||
JSRef XMLHttpRequest -> IO JSString
|
||||
|
||||
xmlHttpRequestGetResponseURL ::
|
||||
(IsXMLHttpRequest self, FromJSString result) => self -> IO result
|
||||
xmlHttpRequestGetResponseURL self
|
||||
= fromJSString <$>
|
||||
(ghcjs_dom_xml_http_request_get_response_url
|
||||
(unXMLHttpRequest (toXMLHttpRequest self)))
|
||||
xmlHttpRequestGetResponse :: XMLHttpRequest -> IO (Maybe XhrResponseBody)
|
||||
xmlHttpRequestGetResponse xhr = do
|
||||
mr <- getResponse xhr
|
||||
return $ fmap (\(GObject r) -> XhrResponseBody r) mr
|
||||
|
||||
|
||||
@ -10,14 +10,27 @@ import Language.Haskell.TH
|
||||
|
||||
#ifdef __GHCJS__
|
||||
import qualified GHCJS.Marshal as JS
|
||||
import qualified GHCJS.Marshal.Pure as JS
|
||||
import qualified GHCJS.Foreign as JS
|
||||
import qualified GHCJS.Foreign.Callback as JS
|
||||
import qualified GHCJS.Types as JS
|
||||
import qualified GHCJS.Buffer as JS
|
||||
import GHCJS.DOM
|
||||
import GHCJS.DOM.Types
|
||||
import GHCJS.DOM.Types hiding (fromJSString)
|
||||
import qualified GHCJS.DOM.Types as JS
|
||||
import qualified JavaScript.Array as JS
|
||||
import qualified JavaScript.Cast as JS
|
||||
import qualified JavaScript.Object as JS
|
||||
import qualified JavaScript.Object.Internal (Object (..))
|
||||
import qualified GHCJS.Foreign.Callback.Internal (Callback (..))
|
||||
import qualified JavaScript.Array.Internal (SomeJSArray (..))
|
||||
import qualified JavaScript.TypedArray.ArrayBuffer as JSArrayBuffer
|
||||
|
||||
import Data.Word
|
||||
import Foreign.Ptr
|
||||
import Foreign.C.Types
|
||||
import Data.Hashable
|
||||
import Text.Encoding.Z
|
||||
#else
|
||||
import System.Glib.FFI
|
||||
import Graphics.UI.Gtk.WebKit.WebView
|
||||
@ -27,7 +40,6 @@ import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSStringRef
|
||||
import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSValueRef
|
||||
import Graphics.UI.Gtk.WebKit.JavaScriptCore.WebFrame
|
||||
import Graphics.UI.Gtk.WebKit.DOM.Node
|
||||
import Graphics.UI.Gtk.WebKit.Types
|
||||
#endif
|
||||
|
||||
import Control.Monad
|
||||
@ -42,7 +54,6 @@ import Data.ByteString (ByteString)
|
||||
import qualified Data.ByteString as BS
|
||||
import Control.Concurrent
|
||||
import Data.Coerce
|
||||
import Text.Encoding.Z
|
||||
import Data.Monoid
|
||||
|
||||
class Monad m => HasWebView m where
|
||||
@ -77,7 +88,7 @@ withWebViewSingleton wv f = f $ WebViewSingleton wv
|
||||
newtype WebViewSingleton x = WebViewSingleton { unWebViewSingleton :: WebView }
|
||||
|
||||
#ifdef __GHCJS__
|
||||
type JSFFI_Internal = JS.JSArray (JSRef JSCtx_IO) -> IO (JS.JSRef (JSRef JSCtx_IO))
|
||||
type JSFFI_Internal = JS.MutableJSArray -> IO JS.JSVal
|
||||
newtype JSFFI = JSFFI JSFFI_Internal
|
||||
#else
|
||||
newtype JSFFI = JSFFI String
|
||||
@ -131,48 +142,48 @@ class Monad m => MonadJS x m | m -> x where
|
||||
data JSCtx_IO
|
||||
|
||||
instance IsJSContext JSCtx_IO where
|
||||
newtype JSRef JSCtx_IO = JSRef_IO { unJSRef_IO :: JS.JSRef (JSRef JSCtx_IO) }
|
||||
newtype JSRef JSCtx_IO = JSRef_IO { unJSRef_IO :: JS.JSVal }
|
||||
|
||||
instance MonadJS JSCtx_IO IO where
|
||||
runJS (JSFFI f) l = liftM JSRef_IO . f =<< JS.toArray (coerce l)
|
||||
runJS (JSFFI f) l = liftM JSRef_IO . f =<< JS.fromListIO (coerce l)
|
||||
forkJS = forkIO
|
||||
mkJSUndefined = return $ JSRef_IO JS.jsUndefined
|
||||
isJSNull (JSRef_IO r) = return $ JS.isNull r
|
||||
isJSUndefined (JSRef_IO r) = return $ JS.isUndefined r
|
||||
fromJSBool (JSRef_IO r) = return $ JS.fromJSBool $ JS.castRef r
|
||||
fromJSString (JSRef_IO r) = return $ JS.fromJSString $ JS.castRef r
|
||||
fromJSArray (JSRef_IO r) = liftM coerce $ JS.fromArray $ JS.castRef r
|
||||
fromJSUint8Array (JSRef_IO r) = JS.bufferByteString 0 0 $ JS.castRef r
|
||||
fromJSBool (JSRef_IO r) = return $ JS.fromJSBool r
|
||||
fromJSString (JSRef_IO r) = return $ JS.fromJSString $ JS.pFromJSVal r
|
||||
fromJSArray (JSRef_IO r) = liftM coerce $ JS.toListIO $ coerce r
|
||||
fromJSUint8Array (JSRef_IO r) = liftM (JS.toByteString 0 Nothing . JS.createFromArrayBuffer) $ JSArrayBuffer.unsafeFreeze $ JS.pFromJSVal r --TODO: Assert that this is immutable
|
||||
fromJSNumber (JSRef_IO r) = do
|
||||
Just n <- JS.fromJSRef $ JS.castRef r
|
||||
Just n <- JS.fromJSVal r
|
||||
return n
|
||||
withJSBool b f = f $ JSRef_IO $ JS.castRef $ JS.toJSBool b
|
||||
withJSString s f = f $ JSRef_IO $ JS.castRef $ JS.toJSString s
|
||||
withJSBool b f = f $ JSRef_IO $ JS.toJSBool b
|
||||
withJSString s f = f $ JSRef_IO $ JS.pToJSVal $ JS.toJSString s
|
||||
withJSNumber n f = do
|
||||
r <- JS.toJSRef n
|
||||
f $ JSRef_IO $ JS.castRef r
|
||||
r <- JS.toJSVal n
|
||||
f $ JSRef_IO r
|
||||
withJSArray l f = do
|
||||
r <- JS.toArray $ coerce l
|
||||
f $ JSRef_IO $ JS.castRef r
|
||||
r <- JS.fromListIO $ coerce l
|
||||
f $ JSRef_IO $ coerce r
|
||||
withJSUint8Array payload f = BS.useAsCString payload $ \cStr -> do
|
||||
ba <- extractByteArray cStr $ BS.length payload
|
||||
f $ JSUint8Array $ JSRef_IO ba
|
||||
mkJSFun f = do
|
||||
cb <- JS.syncCallback1 JS.AlwaysRetain True $ \args -> do
|
||||
l <- JS.fromArray args
|
||||
cb <- JS.syncCallback1' $ \args -> do
|
||||
l <- JS.toListIO $ coerce args
|
||||
JSRef_IO result <- f $ coerce l
|
||||
return $ JS.castRef result
|
||||
liftM (JSFun . JSRef_IO) $ funWithArguments cb
|
||||
freeJSFun (JSFun (JSRef_IO r)) = JS.release $ JS.castRef r
|
||||
setJSProp s (JSRef_IO v) (JSRef_IO o) = JS.setProp s v o
|
||||
return result
|
||||
liftM (JSFun . JSRef_IO) $ funWithArguments $ coerce cb
|
||||
freeJSFun (JSFun (JSRef_IO r)) = JS.releaseCallback $ coerce r
|
||||
setJSProp s (JSRef_IO v) (JSRef_IO o) = JS.setProp (JS.toJSString s) v $ coerce o
|
||||
getJSProp s (JSRef_IO o) = do
|
||||
r <- JS.getProp s o
|
||||
r <- JS.getProp (JS.toJSString s) $ coerce o
|
||||
return $ JSRef_IO r
|
||||
withJSNode n f = f $ JSRef_IO $ JS.castRef $ unNode n
|
||||
withJSNode n f = f $ JSRef_IO $ unNode n
|
||||
|
||||
foreign import javascript unsafe "new Uint8Array($1_1.buf, $1_2, $2)" extractByteArray :: Ptr CChar -> Int -> IO (JS.JSRef (JSRef JSCtx_IO))
|
||||
|
||||
foreign import javascript unsafe "function(){ return $1(arguments); }" funWithArguments :: JS.JSFun (JS.JSArray (JS.JSRef b) -> IO a) -> IO (JS.JSRef (JSRef JSCtx_IO))
|
||||
foreign import javascript unsafe "function(){ return $1(arguments); }" funWithArguments :: JS.Callback (JS.MutableJSArray -> IO a) -> IO JS.JSVal
|
||||
|
||||
#else
|
||||
|
||||
|
||||
@ -19,8 +19,7 @@ import Control.Monad.State hiding (mapM, mapM_, forM, forM_, sequence)
|
||||
import qualified Control.Monad.State.Strict as Strict hiding (mapM, mapM_, forM, forM_, sequence)
|
||||
import Data.Dependent.Sum (DSum (..))
|
||||
import GHCJS.DOM.Types hiding (Event)
|
||||
import GHCJS.DOM (WebView)
|
||||
import Control.Monad.Exception
|
||||
--import GHCJS.DOM (WebView)
|
||||
|
||||
-- | Alias for Data.Map.singleton
|
||||
(=:) :: k -> a -> Map k a
|
||||
@ -80,14 +79,14 @@ instance MonadIORestore m => MonadIORestore (ReaderT r m) where
|
||||
|
||||
class (MonadRef h, Ref h ~ Ref m, MonadRef m) => HasPostGui t h m | m -> t h where
|
||||
askPostGui :: m (h () -> IO ())
|
||||
askRunWithActions :: m ([DSum (EventTrigger t)] -> h ())
|
||||
askRunWithActions :: m ([DSum (EventTrigger t) Identity] -> h ())
|
||||
scheduleFollowup :: Ref m (Maybe (EventTrigger t a)) -> a -> m ()
|
||||
|
||||
runFrameWithTriggerRef :: (HasPostGui t h m, MonadRef m, MonadIO m) => Ref m (Maybe (EventTrigger t a)) -> a -> m ()
|
||||
runFrameWithTriggerRef r a = do
|
||||
postGui <- askPostGui
|
||||
runWithActions <- askRunWithActions
|
||||
liftIO . postGui $ mapM_ (\t -> runWithActions [t :=> a]) =<< readRef r
|
||||
liftIO . postGui $ mapM_ (\t -> runWithActions [t :=> Identity a]) =<< readRef r
|
||||
|
||||
instance HasPostGui t h m => HasPostGui t h (ReaderT r m) where
|
||||
askPostGui = lift askPostGui
|
||||
@ -143,7 +142,7 @@ performEventAsync e = do
|
||||
addVoidAction $ ffor e $ \o -> do
|
||||
postGui <- askPostGui
|
||||
runWithActions <- askRunWithActions
|
||||
o $ \a -> postGui $ mapM_ (\t -> runWithActions [t :=> a]) =<< readRef reResultTrigger
|
||||
o $ \a -> postGui $ mapM_ (\t -> runWithActions [t :=> Identity a]) =<< readRef reResultTrigger
|
||||
return eResult
|
||||
|
||||
getPostBuild :: MonadWidget t m => m (Event t ())
|
||||
|
||||
@ -5,12 +5,11 @@ import Prelude hiding (mapM, mapM_, concat, sequence, sequence_)
|
||||
|
||||
import Reflex.Dom.Internal.Foreign
|
||||
import Reflex.Dom.Class
|
||||
import Foreign.JavaScript.TH
|
||||
|
||||
import GHCJS.DOM hiding (runWebGUI)
|
||||
import GHCJS.DOM.Types hiding (Widget, unWidget, Event)
|
||||
import GHCJS.DOM.Node
|
||||
import GHCJS.DOM.HTMLElement
|
||||
import GHCJS.DOM.Element
|
||||
import GHCJS.DOM.Document
|
||||
import Reflex.Class
|
||||
import Reflex.Host.Class
|
||||
@ -38,9 +37,9 @@ newtype EventTriggerRef t m a = EventTriggerRef { unEventTriggerRef :: Ref m (Ma
|
||||
data GuiEnv t h x
|
||||
= GuiEnv { _guiEnvDocument :: !HTMLDocument
|
||||
, _guiEnvPostGui :: !(h () -> IO ())
|
||||
, _guiEnvRunWithActions :: !([DSum (EventTrigger t)] -> h ())
|
||||
, _guiEnvRunWithActions :: !([DSum (EventTrigger t) Identity] -> h ())
|
||||
, _guiEnvWebView :: !(WebViewSingleton x)
|
||||
, _guiEnvFollowupEvents :: Ref h [DSum (EventTriggerRef t h)]
|
||||
, _guiEnvFollowupEvents :: Ref h [DSum (EventTriggerRef t h) Identity]
|
||||
}
|
||||
|
||||
--TODO: Poorly named
|
||||
@ -110,7 +109,7 @@ instance (MonadRef h, Ref h ~ Ref m, MonadRef m) => HasPostGui t h (Gui t h x m)
|
||||
askRunWithActions = Gui $ view guiEnvRunWithActions
|
||||
scheduleFollowup r a = Gui $ do
|
||||
followupEventsRef <- view guiEnvFollowupEvents
|
||||
modifyRef' followupEventsRef $ ((EventTriggerRef r :=> a) :)
|
||||
modifyRef' followupEventsRef $ ((EventTriggerRef r :=> Identity a) :)
|
||||
|
||||
instance HasPostGui t h m => HasPostGui t h (Widget t m) where
|
||||
askPostGui = lift askPostGui
|
||||
@ -174,6 +173,10 @@ instance ( MonadRef m, Ref m ~ Ref IO, MonadRef h, Ref h ~ Ref IO --TODO: Should
|
||||
-- runWidget :: (Monad m, IsNode n, Reflex t) => n -> Widget t m a -> m (a, Event t (m ()))
|
||||
getRunWidget = return runWidget
|
||||
|
||||
getQuitWidget :: MonadWidget t m => m (WidgetHost m ())
|
||||
getQuitWidget = return $ do WebViewSingleton wv <- askWebView
|
||||
liftIO $ quitWebView wv
|
||||
|
||||
runWidget :: (Monad m, Reflex t, IsNode n) => n -> Widget t (Gui t h x m) a -> WidgetHost (Widget t (Gui t h x m)) (a, WidgetHost (Widget t (Gui t h x m)) (), Event t (WidgetHost (Widget t (Gui t h x m)) ()))
|
||||
runWidget rootElement w = do
|
||||
(result, WidgetState postBuild voidActions) <- runStateT (runReaderT (unWidget w) (WidgetEnv $ toNode rootElement)) (WidgetState (return ()) [])
|
||||
@ -191,24 +194,24 @@ holdOnStartup a0 ma = do
|
||||
mainWidget :: (forall x. Widget Spider (Gui Spider (WithWebView x SpiderHost) x (HostFrame Spider)) ()) -> IO ()
|
||||
mainWidget w = runWebGUI $ \webView -> withWebViewSingleton webView $ \webViewSing -> do
|
||||
Just doc <- liftM (fmap castToHTMLDocument) $ webViewGetDomDocument webView
|
||||
Just body <- documentGetBody doc
|
||||
Just body <- getBody doc
|
||||
attachWidget body webViewSing w
|
||||
|
||||
--TODO: The x's should be unified here
|
||||
mainWidgetWithHead :: (forall x. Widget Spider (Gui Spider (WithWebView x SpiderHost) x (HostFrame Spider)) ()) -> (forall x. Widget Spider (Gui Spider (WithWebView x SpiderHost) x (HostFrame Spider)) ()) -> IO ()
|
||||
mainWidgetWithHead h b = runWebGUI $ \webView -> withWebViewSingleton webView $ \webViewSing -> do
|
||||
Just doc <- liftM (fmap castToHTMLDocument) $ webViewGetDomDocument webView
|
||||
Just headElement <- liftM (fmap castToHTMLElement) $ documentGetHead doc
|
||||
Just headElement <- liftM (fmap castToHTMLElement) $ getHead doc
|
||||
attachWidget headElement webViewSing h
|
||||
Just body <- documentGetBody doc
|
||||
Just body <- getBody doc
|
||||
attachWidget body webViewSing b
|
||||
|
||||
mainWidgetWithCss :: ByteString -> (forall x. Widget Spider (Gui Spider (WithWebView x SpiderHost) x (HostFrame Spider)) ()) -> IO ()
|
||||
mainWidgetWithCss css w = runWebGUI $ \webView -> withWebViewSingleton webView $ \webViewSing -> do
|
||||
Just doc <- liftM (fmap castToHTMLDocument) $ webViewGetDomDocument webView
|
||||
Just headElement <- liftM (fmap castToHTMLElement) $ documentGetHead doc
|
||||
htmlElementSetInnerHTML headElement $ "<style>" <> T.unpack (decodeUtf8 css) <> "</style>" --TODO: Fix this
|
||||
Just body <- documentGetBody doc
|
||||
Just headElement <- liftM (fmap castToHTMLElement) $ getHead doc
|
||||
setInnerHTML headElement . Just $ "<style>" <> T.unpack (decodeUtf8 css) <> "</style>" --TODO: Fix this
|
||||
Just body <- getBody doc
|
||||
attachWidget body webViewSing w
|
||||
|
||||
instance HasPostGui t h m => HasPostGui t (WithWebView x h) (WithWebView x m) where
|
||||
@ -252,7 +255,7 @@ instance MonadReflexHost t m => MonadReflexHost t (WithWebView x m) where
|
||||
|
||||
attachWidget :: forall e x a. (IsHTMLElement e) => e -> WebViewSingleton x -> Widget Spider (Gui Spider (WithWebView x SpiderHost) x (HostFrame Spider)) a -> IO a
|
||||
attachWidget rootElement wv w = runSpiderHost $ flip runWithWebView wv $ do --TODO: It seems to re-run this handler if the URL changes, even if it's only the fragment
|
||||
Just doc <- liftM (fmap castToHTMLDocument) $ liftIO $ nodeGetOwnerDocument rootElement
|
||||
Just doc <- liftM (fmap castToHTMLDocument) $ getOwnerDocument rootElement
|
||||
frames <- liftIO newChan
|
||||
followupEvents <- liftIO $ newIORef []
|
||||
rec let guiEnv = GuiEnv doc (writeChan frames . runSpiderHost . flip runWithWebView wv) runWithActions wv followupEvents :: GuiEnv Spider (WithWebView x SpiderHost) x
|
||||
@ -273,13 +276,13 @@ attachWidget rootElement wv w = runSpiderHost $ flip runWithWebView wv $ do --TO
|
||||
Just t -> return $ Just (t :=> a)
|
||||
let fe'' = catMaybes fe'
|
||||
when (not $ null fe'') $ runWithActions fe''
|
||||
Just df <- liftIO $ documentCreateDocumentFragment doc
|
||||
Just df <- liftIO $ createDocumentFragment doc
|
||||
(result, voidAction) <- runHostFrame $ flip runGui guiEnv $ do
|
||||
(r, postBuild, va) <- runWidget df w
|
||||
postBuild -- This probably shouldn't be run inside the frame; we need to make sure we don't run a frame inside of a frame
|
||||
return (r, va)
|
||||
liftIO $ htmlElementSetInnerHTML rootElement ""
|
||||
_ <- liftIO $ nodeAppendChild rootElement $ Just df
|
||||
setInnerHTML rootElement $ Just ""
|
||||
_ <- appendChild rootElement $ Just df
|
||||
voidActionHandle <- subscribeEvent voidAction --TODO: Should be unnecessary
|
||||
--postGUISync seems to leak memory on GHC (unknown on GHCJS)
|
||||
doFollowup -- This must go after voidActionHandle is subscribed; otherwise, a loop results
|
||||
|
||||
@ -166,7 +166,7 @@ inhomogeneousPoisson
|
||||
inhomogeneousPoisson rnd rate maxRate t0 =
|
||||
inhomogeneousPoissonFrom rnd rate maxRate t0 =<< getPostBuild
|
||||
|
||||
-- | Block occurrences of an Event until th given number of seconds elapses without
|
||||
-- | Block occurrences of an Event until the given number of seconds elapses without
|
||||
-- the Event firing, at which point the last occurrence of the Event will fire.
|
||||
debounce :: MonadWidget t m => NominalDiffTime -> Event t a -> m (Event t a)
|
||||
debounce dt e = do
|
||||
|
||||
@ -44,10 +44,10 @@ webSocket url config = do
|
||||
let onMessage :: ByteString -> IO ()
|
||||
onMessage m = postGui $ do
|
||||
mt <- readRef eRecvTriggerRef
|
||||
forM_ mt $ \t -> runWithActions [t :=> m]
|
||||
forM_ mt $ \t -> runWithActions [t :=> Identity m]
|
||||
onOpen = postGui $ do
|
||||
mt <- readRef eOpenTriggerRef
|
||||
forM_ mt $ \t -> runWithActions [t :=> ()]
|
||||
forM_ mt $ \t -> runWithActions [t :=> Identity ()]
|
||||
start = do
|
||||
ws <- liftIO $ newWebSocket wv url onMessage onOpen $ do
|
||||
void $ forkIO $ do --TODO: Is the fork necessary, or do event handlers run in their own threads automatically?
|
||||
|
||||
@ -21,12 +21,12 @@ import Control.Monad.Reader hiding (mapM, mapM_, forM, forM_, sequence, sequence
|
||||
import Control.Monad.State hiding (state, mapM, mapM_, forM, forM_, sequence, sequence_)
|
||||
import GHCJS.DOM.Node
|
||||
import GHCJS.DOM.UIEvent
|
||||
import GHCJS.DOM.EventM (event, EventM, stopPropagation)
|
||||
import GHCJS.DOM.EventM (on, event, EventM, stopPropagation)
|
||||
import GHCJS.DOM.Document
|
||||
import GHCJS.DOM.Element
|
||||
import GHCJS.DOM.HTMLElement
|
||||
import GHCJS.DOM.Types hiding (Widget (..), unWidget, Event)
|
||||
import GHCJS.DOM.NamedNodeMap
|
||||
import GHCJS.DOM.Element as E
|
||||
import GHCJS.DOM.Types hiding (Event)
|
||||
import qualified GHCJS.DOM.Types as DOM (Event)
|
||||
import GHCJS.DOM.NamedNodeMap as NNM
|
||||
import Control.Lens hiding (element, children)
|
||||
import Data.These
|
||||
import Data.Align
|
||||
@ -60,27 +60,27 @@ class Attributes m a where
|
||||
addAttributes :: IsElement e => a -> e -> m ()
|
||||
|
||||
instance MonadIO m => Attributes m AttributeMap where
|
||||
addAttributes curAttrs e = liftIO $ imapM_ (elementSetAttribute e) curAttrs
|
||||
addAttributes curAttrs e = imapM_ (setAttribute e) curAttrs
|
||||
|
||||
instance MonadWidget t m => Attributes m (Dynamic t AttributeMap) where
|
||||
addAttributes attrs e = do
|
||||
schedulePostBuild $ do
|
||||
curAttrs <- sample $ current attrs
|
||||
liftIO $ imapM_ (elementSetAttribute e) curAttrs
|
||||
imapM_ (setAttribute e) curAttrs
|
||||
addVoidAction $ flip fmap (updated attrs) $ \newAttrs -> liftIO $ do
|
||||
oldAttrs <- maybe (return Set.empty) namedNodeMapGetNames =<< elementGetAttributes e
|
||||
forM_ (Set.toList $ oldAttrs `Set.difference` Map.keysSet newAttrs) $ elementRemoveAttribute e
|
||||
imapM_ (elementSetAttribute e) newAttrs --TODO: avoid re-setting unchanged attributes; possibly do the compare using Align in haskell
|
||||
oldAttrs <- maybe (return Set.empty) namedNodeMapGetNames =<< getAttributes e
|
||||
forM_ (Set.toList $ oldAttrs `Set.difference` Map.keysSet newAttrs) $ removeAttribute e
|
||||
imapM_ (setAttribute e) newAttrs --TODO: avoid re-setting unchanged attributes; possibly do the compare using Align in haskell
|
||||
|
||||
buildEmptyElementNS :: (MonadWidget t m, Attributes m attrs) => Maybe String -> String -> attrs -> m Element
|
||||
buildEmptyElementNS mns elementTag attrs = do
|
||||
doc <- askDocument
|
||||
p <- askParent
|
||||
Just e <- liftIO $ case mns of
|
||||
Nothing -> documentCreateElement doc elementTag
|
||||
Just ns -> documentCreateElementNS doc ns elementTag
|
||||
Nothing -> createElement doc (Just elementTag)
|
||||
Just ns -> createElementNS doc (Just ns) (Just elementTag)
|
||||
addAttributes attrs e
|
||||
_ <- liftIO $ nodeAppendChild p $ Just e
|
||||
_ <- appendChild p $ Just e
|
||||
return $ castToElement e
|
||||
|
||||
buildEmptyElement :: (MonadWidget t m, Attributes m attrs) => String -> attrs -> m Element
|
||||
@ -96,13 +96,13 @@ buildElementNS mns elementTag attrs child = do
|
||||
buildElement :: (MonadWidget t m, Attributes m attrs) => String -> attrs -> m a -> m (Element, a)
|
||||
buildElement = buildElementNS Nothing
|
||||
|
||||
namedNodeMapGetNames :: IsNamedNodeMap self => self -> IO (Set String)
|
||||
namedNodeMapGetNames :: NamedNodeMap -> IO (Set String)
|
||||
namedNodeMapGetNames self = do
|
||||
l <- namedNodeMapGetLength self
|
||||
l <- NNM.getLength self
|
||||
let locations = if l == 0 then [] else [0..l-1] -- Can't use 0..l-1 if l is 0 because l is unsigned and will wrap around
|
||||
liftM Set.fromList $ forM locations $ \i -> do
|
||||
Just n <- namedNodeMapItem self i
|
||||
nodeGetNodeName n
|
||||
liftM (Set.fromList . catMaybes) $ forM locations $ \i -> do
|
||||
Just n <- NNM.item self i
|
||||
getNodeName n
|
||||
|
||||
text :: MonadWidget t m => String -> m ()
|
||||
text = void . text'
|
||||
@ -112,8 +112,8 @@ text' :: MonadWidget t m => String -> m Text
|
||||
text' s = do
|
||||
doc <- askDocument
|
||||
p <- askParent
|
||||
Just n <- liftIO $ documentCreateTextNode doc s
|
||||
_ <- liftIO $ nodeAppendChild p $ Just n
|
||||
Just n <- createTextNode doc s
|
||||
_ <- appendChild p $ Just n
|
||||
return n
|
||||
|
||||
dynText :: MonadWidget t m => Dynamic t String -> m ()
|
||||
@ -121,8 +121,8 @@ dynText s = do
|
||||
n <- text' ""
|
||||
schedulePostBuild $ do
|
||||
curS <- sample $ current s
|
||||
liftIO $ nodeSetNodeValue n curS
|
||||
addVoidAction $ fmap (liftIO . nodeSetNodeValue n) $ updated s
|
||||
setNodeValue n $ Just curS
|
||||
addVoidAction $ fmap (setNodeValue n . Just) $ updated s
|
||||
|
||||
display :: (MonadWidget t m, Show a) => Dynamic t a -> m ()
|
||||
display a = dynText =<< mapDyn show a
|
||||
@ -159,12 +159,12 @@ widgetHoldInternal child0 newChild = do
|
||||
doc <- askDocument
|
||||
runWidget <- getRunWidget
|
||||
let build c = do
|
||||
Just df <- liftIO $ documentCreateDocumentFragment doc
|
||||
Just df <- createDocumentFragment doc
|
||||
(result, postBuild, voidActions) <- runWidget df c
|
||||
scheduleFollowup newChildBuiltTriggerRef (result, voidActions)
|
||||
postBuild
|
||||
mp' <- liftIO $ nodeGetParentNode endPlaceholder
|
||||
forM_ mp' $ \p' -> liftIO $ nodeInsertBefore p' (Just df) (Just endPlaceholder)
|
||||
mp' <- getParentNode endPlaceholder
|
||||
forM_ mp' $ \p' -> insertBefore p' (Just df) (Just endPlaceholder)
|
||||
return ()
|
||||
addVoidAction $ ffor newChild $ \c -> do
|
||||
liftIO $ deleteBetweenExclusive startPlaceholder endPlaceholder
|
||||
@ -209,7 +209,7 @@ listWithKeyShallowDiff initialVals valsChanged mkChild = do
|
||||
Nothing -> Just Nothing -- Even if we let a Nothing through when the element doesn't already exist, this doesn't cause a problem because it is ignored
|
||||
Just _ -> Nothing -- We don't want to let spurious re-creations of items through
|
||||
listHoldWithKey initialVals (attachWith (flip (Map.differenceWith relevantDiff)) (current sentVals) valsChanged) $ \k v ->
|
||||
mkChild k v $ select childValChangedSelector $ Const2 k
|
||||
mkChild k v $ Reflex.select childValChangedSelector $ Const2 k
|
||||
|
||||
-- | Display the given map of items using the builder function provided, and update it with the given event. 'Nothing' entries will delete the corresponding children, and 'Just' entries will create or replace them. Since child events do not take any signal arguments, they are always rebuilt. To update a child without rebuilding, either embed signals in the map's values, or refer to them directly in the builder function.
|
||||
listHoldWithKey :: (Ord k, MonadWidget t m) => Map k v -> Event t (Map k (Maybe v)) -> (k -> v -> m a) -> m (Dynamic t (Map k a))
|
||||
@ -224,13 +224,13 @@ listHoldWithKey initialVals valsChanged mkChild = do
|
||||
result <- mkChild k v
|
||||
childEnd <- text' ""
|
||||
return (result, (childStart, childEnd))
|
||||
Just dfOrig <- liftIO $ documentCreateDocumentFragment doc
|
||||
Just dfOrig <- createDocumentFragment doc
|
||||
initialState <- iforM initialVals $ \k v -> subWidgetWithVoidActions (toNode dfOrig) $ wrapChild k v --Note: we have to use subWidgetWithVoidActions rather than runWidget here, because running post-build actions during build can cause not-yet-constructed values to be read
|
||||
stateRef <- liftIO $ newIORef initialState
|
||||
children <- holdDyn initialState newChildren
|
||||
tellWidgetOutput =<< mapDyn (fmap snd) children
|
||||
mpOrig <- liftIO $ nodeGetParentNode endPlaceholder
|
||||
forM_ mpOrig $ \pOrig -> liftIO $ nodeInsertBefore pOrig (Just dfOrig) (Just endPlaceholder)
|
||||
mpOrig <- getParentNode endPlaceholder
|
||||
forM_ mpOrig $ \pOrig -> insertBefore pOrig (Just dfOrig) (Just endPlaceholder)
|
||||
addVoidAction $ flip fmap valsChanged $ \newVals -> do
|
||||
curState <- liftIO $ readIORef stateRef
|
||||
--TODO: Should we remove the parent from the DOM first to avoid reflows?
|
||||
@ -240,24 +240,24 @@ listHoldWithKey initialVals valsChanged mkChild = do
|
||||
return Nothing
|
||||
These ((_, (start, end)), _) (Just v) -> do -- Replacing existing child
|
||||
liftIO $ deleteBetweenExclusive start end
|
||||
Just df <- liftIO $ documentCreateDocumentFragment doc
|
||||
Just df <- createDocumentFragment doc
|
||||
(childResult, childPostBuild, childVoidAction) <- lift $ buildChild df k v
|
||||
let s = (childResult, childVoidAction)
|
||||
modify (>>childPostBuild)
|
||||
mp <- liftIO $ nodeGetParentNode end
|
||||
forM_ mp $ \p -> liftIO $ nodeInsertBefore p (Just df) (Just end)
|
||||
mp <- getParentNode end
|
||||
forM_ mp $ \p -> insertBefore p (Just df) (Just end)
|
||||
return $ Just s
|
||||
That Nothing -> return Nothing -- Deleting non-existent child
|
||||
That (Just v) -> do -- Creating new child
|
||||
Just df <- liftIO $ documentCreateDocumentFragment doc
|
||||
Just df <- createDocumentFragment doc
|
||||
(childResult, childPostBuild, childVoidAction) <- lift $ buildChild df k v
|
||||
let s = (childResult, childVoidAction)
|
||||
modify (>>childPostBuild)
|
||||
let placeholder = case Map.lookupGT k curState of
|
||||
Nothing -> endPlaceholder
|
||||
Just (_, ((_, (start, _)), _)) -> start
|
||||
mp <- liftIO $ nodeGetParentNode placeholder
|
||||
forM_ mp $ \p -> liftIO $ nodeInsertBefore p (Just df) (Just placeholder)
|
||||
mp <- getParentNode placeholder
|
||||
forM_ mp $ \p -> insertBefore p (Just df) (Just placeholder)
|
||||
return $ Just s
|
||||
This state -> do -- No change
|
||||
return $ Just state
|
||||
@ -303,47 +303,56 @@ selectViewListWithKey_ selection vals mkChild = liftM (fmap fst) $ selectViewLis
|
||||
-- | s and e must both be children of the same node and s must precede e
|
||||
deleteBetweenExclusive :: (IsNode start, IsNode end) => start -> end -> IO ()
|
||||
deleteBetweenExclusive s e = do
|
||||
mCurrentParent <- nodeGetParentNode e -- May be different than it was at initial construction, e.g., because the parent may have dumped us in from a DocumentFragment
|
||||
mCurrentParent <- getParentNode e -- May be different than it was at initial construction, e.g., because the parent may have dumped us in from a DocumentFragment
|
||||
case mCurrentParent of
|
||||
Nothing -> return () --TODO: Is this the right behavior?
|
||||
Just currentParent -> do
|
||||
let go = do
|
||||
Just x <- nodeGetPreviousSibling e -- This can't be Nothing because we should hit 's' first
|
||||
Just x <- getPreviousSibling e -- This can't be Nothing because we should hit 's' first
|
||||
when (toNode s /= toNode x) $ do
|
||||
_ <- nodeRemoveChild currentParent $ Just x
|
||||
_ <- removeChild currentParent $ Just x
|
||||
go
|
||||
go
|
||||
|
||||
-- | s and e must both be children of the same node and s must precede e
|
||||
deleteBetweenInclusive :: (IsNode start, IsNode end) => start -> end -> IO ()
|
||||
deleteBetweenInclusive s e = do
|
||||
mCurrentParent <- nodeGetParentNode e -- May be different than it was at initial construction, e.g., because the parent may have dumped us in from a DocumentFragment
|
||||
mCurrentParent <- getParentNode e -- May be different than it was at initial construction, e.g., because the parent may have dumped us in from a DocumentFragment
|
||||
case mCurrentParent of
|
||||
Nothing -> return () --TODO: Is this the right behavior?
|
||||
Just currentParent -> do
|
||||
let go = do
|
||||
Just x <- nodeGetPreviousSibling e -- This can't be Nothing because we should hit 's' first
|
||||
_ <- nodeRemoveChild currentParent $ Just x
|
||||
Just x <- getPreviousSibling e -- This can't be Nothing because we should hit 's' first
|
||||
_ <- removeChild currentParent $ Just x
|
||||
when (toNode s /= toNode x) go
|
||||
go
|
||||
_ <- nodeRemoveChild currentParent $ Just e
|
||||
_ <- removeChild currentParent $ Just e
|
||||
return ()
|
||||
|
||||
nodeClear :: IsNode self => self -> IO ()
|
||||
nodeClear n = do
|
||||
mfc <- getFirstChild n
|
||||
case mfc of
|
||||
Nothing -> return ()
|
||||
Just fc -> do
|
||||
_ <- removeChild n $ Just fc
|
||||
nodeClear n
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Adapters
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
wrapDomEvent :: (Functor (Event t), MonadIO m, MonadSample t m, MonadReflexCreateTrigger t m, Reflex t, HasPostGui t h m) => e -> (e -> EventM event e () -> IO (IO ())) -> EventM event e a -> m (Event t a)
|
||||
wrapDomEvent :: (Functor (Event t), MonadIO m, MonadSample t m, MonadReflexCreateTrigger t m, Reflex t, HasPostGui t h m) => e -> (e -> EventM e event () -> IO (IO ())) -> EventM e event a -> m (Event t a)
|
||||
wrapDomEvent element elementOnevent getValue = wrapDomEventMaybe element elementOnevent $ liftM Just getValue
|
||||
|
||||
wrapDomEventMaybe :: (Functor (Event t), MonadIO m, MonadSample t m, MonadReflexCreateTrigger t m, Reflex t, HasPostGui t h m) => e -> (e -> EventM event e () -> IO (IO ())) -> EventM event e (Maybe a) -> m (Event t a)
|
||||
wrapDomEventMaybe :: (Functor (Event t), MonadIO m, MonadSample t m, MonadReflexCreateTrigger t m, Reflex t, HasPostGui t h m) => e -> (e -> EventM e event () -> IO (IO ())) -> EventM e event (Maybe a) -> m (Event t a)
|
||||
wrapDomEventMaybe element elementOnevent getValue = do
|
||||
postGui <- askPostGui
|
||||
runWithActions <- askRunWithActions
|
||||
e <- newEventWithTrigger $ \et -> do
|
||||
unsubscribe <- {-# SCC "a" #-} liftIO $ {-# SCC "b" #-} elementOnevent element $ {-# SCC "c" #-} do
|
||||
mv <- {-# SCC "d" #-} getValue
|
||||
forM_ mv $ \v -> liftIO $ postGui $ runWithActions [et :=> v]
|
||||
forM_ mv $ \v -> liftIO $ postGui $ runWithActions [et :=> Identity v]
|
||||
return $ liftIO $ do
|
||||
{-# SCC "e" #-} unsubscribe
|
||||
return $! {-# SCC "f" #-} e
|
||||
@ -377,11 +386,11 @@ data EventTag
|
||||
| MouseoutTag
|
||||
| MouseoverTag
|
||||
| MouseupTag
|
||||
-- | MousewheelTag -- webkitgtk only provides elementOnmousewheel (not elementOnwheel), but firefox does not support the mousewheel event; we should provide wheel (the equivalent, standard event), but we will need to make sure webkitgtk supports it first
|
||||
| MousewheelTag
|
||||
| ScrollTag
|
||||
| SelectTag
|
||||
| SubmitTag
|
||||
-- | WheelTag -- See MousewheelTag
|
||||
| WheelTag
|
||||
| BeforecutTag
|
||||
| CutTag
|
||||
| BeforecopyTag
|
||||
@ -425,11 +434,11 @@ data EventName :: EventTag -> * where
|
||||
Mouseout :: EventName 'MouseoutTag
|
||||
Mouseover :: EventName 'MouseoverTag
|
||||
Mouseup :: EventName 'MouseupTag
|
||||
--Mousewheel :: EventName 'MousewheelTag
|
||||
Mousewheel :: EventName 'MousewheelTag
|
||||
Scroll :: EventName 'ScrollTag
|
||||
Select :: EventName 'SelectTag
|
||||
Submit :: EventName 'SubmitTag
|
||||
--Wheel :: EventName 'WheelTag
|
||||
Wheel :: EventName 'WheelTag
|
||||
Beforecut :: EventName 'BeforecutTag
|
||||
Cut :: EventName 'CutTag
|
||||
Beforecopy :: EventName 'BeforecopyTag
|
||||
@ -446,8 +455,8 @@ data EventName :: EventTag -> * where
|
||||
|
||||
type family EventType en where
|
||||
EventType 'AbortTag = UIEvent
|
||||
EventType 'BlurTag = UIEvent
|
||||
EventType 'ChangeTag = UIEvent
|
||||
EventType 'BlurTag = FocusEvent
|
||||
EventType 'ChangeTag = DOM.Event
|
||||
EventType 'ClickTag = MouseEvent
|
||||
EventType 'ContextmenuTag = MouseEvent
|
||||
EventType 'DblclickTag = MouseEvent
|
||||
@ -459,87 +468,87 @@ type family EventType en where
|
||||
EventType 'DragstartTag = MouseEvent
|
||||
EventType 'DropTag = MouseEvent
|
||||
EventType 'ErrorTag = UIEvent
|
||||
EventType 'FocusTag = UIEvent
|
||||
EventType 'InputTag = UIEvent
|
||||
EventType 'InvalidTag = UIEvent
|
||||
EventType 'KeydownTag = UIEvent
|
||||
EventType 'KeypressTag = UIEvent
|
||||
EventType 'KeyupTag = UIEvent
|
||||
EventType 'FocusTag = FocusEvent
|
||||
EventType 'InputTag = DOM.Event
|
||||
EventType 'InvalidTag = DOM.Event
|
||||
EventType 'KeydownTag = KeyboardEvent
|
||||
EventType 'KeypressTag = KeyboardEvent
|
||||
EventType 'KeyupTag = KeyboardEvent
|
||||
EventType 'LoadTag = UIEvent
|
||||
EventType 'MousedownTag = MouseEvent
|
||||
EventType 'MouseenterTag = UIEvent
|
||||
EventType 'MouseleaveTag = UIEvent
|
||||
EventType 'MouseenterTag = MouseEvent
|
||||
EventType 'MouseleaveTag = MouseEvent
|
||||
EventType 'MousemoveTag = MouseEvent
|
||||
EventType 'MouseoutTag = MouseEvent
|
||||
EventType 'MouseoverTag = MouseEvent
|
||||
EventType 'MouseupTag = MouseEvent
|
||||
--EventType 'MousewheelTag = MouseEvent
|
||||
EventType 'MousewheelTag = MouseEvent
|
||||
EventType 'ScrollTag = UIEvent
|
||||
EventType 'SelectTag = UIEvent
|
||||
EventType 'SubmitTag = UIEvent
|
||||
--EventType 'WheelTag = UIEvent
|
||||
EventType 'BeforecutTag = UIEvent
|
||||
EventType 'CutTag = UIEvent
|
||||
EventType 'BeforecopyTag = UIEvent
|
||||
EventType 'CopyTag = UIEvent
|
||||
EventType 'BeforepasteTag = UIEvent
|
||||
EventType 'PasteTag = UIEvent
|
||||
EventType 'ResetTag = UIEvent
|
||||
EventType 'SearchTag = UIEvent
|
||||
EventType 'SelectstartTag = UIEvent
|
||||
EventType 'TouchstartTag = UIEvent
|
||||
EventType 'TouchmoveTag = UIEvent
|
||||
EventType 'TouchendTag = UIEvent
|
||||
EventType 'TouchcancelTag = UIEvent
|
||||
EventType 'SubmitTag = DOM.Event
|
||||
EventType 'WheelTag = WheelEvent
|
||||
EventType 'BeforecutTag = DOM.Event
|
||||
EventType 'CutTag = DOM.Event
|
||||
EventType 'BeforecopyTag = DOM.Event
|
||||
EventType 'CopyTag = DOM.Event
|
||||
EventType 'BeforepasteTag = DOM.Event
|
||||
EventType 'PasteTag = DOM.Event
|
||||
EventType 'ResetTag = DOM.Event
|
||||
EventType 'SearchTag = DOM.Event
|
||||
EventType 'SelectstartTag = DOM.Event
|
||||
EventType 'TouchstartTag = TouchEvent
|
||||
EventType 'TouchmoveTag = TouchEvent
|
||||
EventType 'TouchendTag = TouchEvent
|
||||
EventType 'TouchcancelTag = TouchEvent
|
||||
|
||||
onEventName :: IsElement e => EventName en -> e -> EventM (EventType en) e () -> IO (IO ())
|
||||
onEventName en = case en of
|
||||
Abort -> elementOnabort
|
||||
Blur -> elementOnblur
|
||||
Change -> elementOnchange
|
||||
Click -> elementOnclick
|
||||
Contextmenu -> elementOncontextmenu
|
||||
Dblclick -> elementOndblclick
|
||||
Drag -> elementOndrag
|
||||
Dragend -> elementOndragend
|
||||
Dragenter -> elementOndragenter
|
||||
Dragleave -> elementOndragleave
|
||||
Dragover -> elementOndragover
|
||||
Dragstart -> elementOndragstart
|
||||
Drop -> elementOndrop
|
||||
Error -> elementOnerror
|
||||
Focus -> elementOnfocus
|
||||
Input -> elementOninput
|
||||
Invalid -> elementOninvalid
|
||||
Keydown -> elementOnkeydown
|
||||
Keypress -> elementOnkeypress
|
||||
Keyup -> elementOnkeyup
|
||||
Load -> elementOnload
|
||||
Mousedown -> elementOnmousedown
|
||||
Mouseenter -> elementOnmouseenter
|
||||
Mouseleave -> elementOnmouseleave
|
||||
Mousemove -> elementOnmousemove
|
||||
Mouseout -> elementOnmouseout
|
||||
Mouseover -> elementOnmouseover
|
||||
Mouseup -> elementOnmouseup
|
||||
--Mousewheel -> elementOnmousewheel
|
||||
Scroll -> elementOnscroll
|
||||
Select -> elementOnselect
|
||||
Submit -> elementOnsubmit
|
||||
--Wheel -> elementOnwheel
|
||||
Beforecut -> elementOnbeforecut
|
||||
Cut -> elementOncut
|
||||
Beforecopy -> elementOnbeforecopy
|
||||
Copy -> elementOncopy
|
||||
Beforepaste -> elementOnbeforepaste
|
||||
Paste -> elementOnpaste
|
||||
Reset -> elementOnreset
|
||||
Search -> elementOnsearch
|
||||
Selectstart -> elementOnselectstart
|
||||
Touchstart -> elementOntouchstart
|
||||
Touchmove -> elementOntouchmove
|
||||
Touchend -> elementOntouchend
|
||||
Touchcancel -> elementOntouchcancel
|
||||
onEventName :: IsElement e => EventName en -> e -> EventM e (EventType en) () -> IO (IO ())
|
||||
onEventName en e = case en of
|
||||
Abort -> on e E.abort
|
||||
Blur -> on e E.blurEvent
|
||||
Change -> on e E.change
|
||||
Click -> on e E.click
|
||||
Contextmenu -> on e E.contextMenu
|
||||
Dblclick -> on e E.dblClick
|
||||
Drag -> on e E.drag
|
||||
Dragend -> on e E.dragEnd
|
||||
Dragenter -> on e E.dragEnter
|
||||
Dragleave -> on e E.dragLeave
|
||||
Dragover -> on e E.dragOver
|
||||
Dragstart -> on e E.dragStart
|
||||
Drop -> on e E.drop
|
||||
Error -> on e E.error
|
||||
Focus -> on e E.focusEvent
|
||||
Input -> on e E.input
|
||||
Invalid -> on e E.invalid
|
||||
Keydown -> on e E.keyDown
|
||||
Keypress -> on e E.keyPress
|
||||
Keyup -> on e E.keyUp
|
||||
Load -> on e E.load
|
||||
Mousedown -> on e E.mouseDown
|
||||
Mouseenter -> on e E.mouseEnter
|
||||
Mouseleave -> on e E.mouseLeave
|
||||
Mousemove -> on e E.mouseMove
|
||||
Mouseout -> on e E.mouseOut
|
||||
Mouseover -> on e E.mouseOver
|
||||
Mouseup -> on e E.mouseUp
|
||||
Mousewheel -> on e E.mouseWheel
|
||||
Scroll -> on e E.scroll
|
||||
Select -> on e E.select
|
||||
Submit -> on e E.submit
|
||||
Wheel -> on e E.wheel
|
||||
Beforecut -> on e E.beforeCut
|
||||
Cut -> on e E.cut
|
||||
Beforecopy -> on e E.beforeCopy
|
||||
Copy -> on e E.copy
|
||||
Beforepaste -> on e E.beforePaste
|
||||
Paste -> on e E.paste
|
||||
Reset -> on e E.reset
|
||||
Search -> on e E.search
|
||||
Selectstart -> on e E.selectStart
|
||||
Touchstart -> on e E.touchStart
|
||||
Touchmove -> on e E.touchMove
|
||||
Touchend -> on e E.touchEnd
|
||||
Touchcancel -> on e E.touchCancel
|
||||
|
||||
newtype EventResult en = EventResult { unEventResult :: EventResultType en }
|
||||
|
||||
@ -588,42 +597,43 @@ type family EventResultType (en :: EventTag) :: * where
|
||||
EventResultType 'TouchmoveTag = ()
|
||||
EventResultType 'TouchendTag = ()
|
||||
EventResultType 'TouchcancelTag = ()
|
||||
EventResultType 'MousewheelTag = ()
|
||||
EventResultType 'WheelTag = ()
|
||||
|
||||
wrapDomEventsMaybe :: (Functor (Event t), IsElement e, MonadIO m, MonadSample t m, MonadReflexCreateTrigger t m, Reflex t, HasPostGui t h m) => e -> (forall en. EventName en -> EventM (EventType en) e (Maybe (f en))) -> m (EventSelector t (WrapArg f EventName))
|
||||
wrapDomEventsMaybe :: (Functor (Event t), IsElement e, MonadIO m, MonadSample t m, MonadReflexCreateTrigger t m, Reflex t, HasPostGui t h m) => e -> (forall en. EventName en -> EventM e (EventType en) (Maybe (f en))) -> m (EventSelector t (WrapArg f EventName))
|
||||
wrapDomEventsMaybe element handlers = do
|
||||
postGui <- askPostGui
|
||||
runWithActions <- askRunWithActions
|
||||
e <- newFanEventWithTrigger $ \(WrapArg en) et -> do
|
||||
unsubscribe <- liftIO $ (onEventName en) element $ do
|
||||
unsubscribe <- onEventName en element $ do
|
||||
mv <- handlers en
|
||||
forM_ mv $ \v -> liftIO $ postGui $ runWithActions [et :=> v]
|
||||
forM_ mv $ \v -> liftIO $ postGui $ runWithActions [et :=> Identity v]
|
||||
return $ liftIO $ do
|
||||
unsubscribe
|
||||
return $! e
|
||||
|
||||
getKeyEvent :: EventM UIEvent e Int
|
||||
getKeyEvent :: EventM e KeyboardEvent Int
|
||||
getKeyEvent = do
|
||||
e <- event
|
||||
liftIO $ do
|
||||
which <- uiEventGetWhich e
|
||||
if which /= 0 then return which else do
|
||||
charCode <- uiEventGetCharCode e
|
||||
if charCode /= 0 then return charCode else
|
||||
uiEventGetKeyCode e
|
||||
which <- getWhich e
|
||||
if which /= 0 then return which else do
|
||||
charCode <- getCharCode e
|
||||
if charCode /= 0 then return charCode else
|
||||
getKeyCode e
|
||||
|
||||
getMouseEventCoords :: EventM MouseEvent e (Int, Int)
|
||||
getMouseEventCoords :: EventM e MouseEvent (Int, Int)
|
||||
getMouseEventCoords = do
|
||||
e <- event
|
||||
liftIO $ bisequence (mouseEventGetClientX e, mouseEventGetClientY e)
|
||||
bisequence (getX e, getY e)
|
||||
|
||||
defaultDomEventHandler :: IsElement e => e -> EventName en -> EventM (EventType en) e (Maybe (EventResult en))
|
||||
defaultDomEventHandler :: IsElement e => e -> EventName en -> EventM e (EventType en) (Maybe (EventResult en))
|
||||
defaultDomEventHandler e evt = liftM (Just . EventResult) $ case evt of
|
||||
Click -> return ()
|
||||
Dblclick -> return ()
|
||||
Keypress -> getKeyEvent
|
||||
Scroll -> getScrollTop e
|
||||
Keydown -> getKeyEvent
|
||||
Keyup -> getKeyEvent
|
||||
Scroll -> liftIO $ elementGetScrollTop e
|
||||
Mousemove -> getMouseEventCoords
|
||||
Mouseup -> getMouseEventCoords
|
||||
Mousedown -> getMouseEventCoords
|
||||
@ -662,8 +672,10 @@ defaultDomEventHandler e evt = liftM (Just . EventResult) $ case evt of
|
||||
Touchmove -> return ()
|
||||
Touchend -> return ()
|
||||
Touchcancel -> return ()
|
||||
Mousewheel -> return ()
|
||||
Wheel -> return ()
|
||||
|
||||
wrapElement :: forall t h m. (Functor (Event t), MonadIO m, MonadSample t m, MonadReflexCreateTrigger t m, Reflex t, HasPostGui t h m) => (forall en. Element -> EventName en -> EventM (EventType en) Element (Maybe (EventResult en))) -> Element -> m (El t)
|
||||
wrapElement :: forall t h m. (Functor (Event t), MonadIO m, MonadSample t m, MonadReflexCreateTrigger t m, Reflex t, HasPostGui t h m) => (forall en. Element -> EventName en -> EventM Element (EventType en) (Maybe (EventResult en))) -> Element -> m (El t)
|
||||
wrapElement eh e = do
|
||||
es <- wrapDomEventsMaybe e $ eh e
|
||||
return $ El e es
|
||||
@ -748,17 +760,15 @@ simpleList xs mkChild = mapDyn (map snd . Map.toList) =<< flip list mkChild =<<
|
||||
elDynHtml' :: MonadWidget t m => String -> Dynamic t String -> m (El t)
|
||||
elDynHtml' elementTag html = do
|
||||
e <- buildEmptyElement elementTag (Map.empty :: Map String String)
|
||||
let h = castToHTMLElement e
|
||||
schedulePostBuild $ liftIO . htmlElementSetInnerHTML h =<< sample (current html)
|
||||
addVoidAction $ fmap (liftIO . htmlElementSetInnerHTML h) $ updated html
|
||||
schedulePostBuild $ setInnerHTML e . Just =<< sample (current html)
|
||||
addVoidAction $ fmap (setInnerHTML e . Just) $ updated html
|
||||
wrapElement defaultDomEventHandler e
|
||||
|
||||
elDynHtmlAttr' :: MonadWidget t m => String -> Map String String -> Dynamic t String -> m (El t)
|
||||
elDynHtmlAttr' elementTag attrs html = do
|
||||
e <- buildEmptyElement elementTag attrs
|
||||
let h = castToHTMLElement e
|
||||
schedulePostBuild $ liftIO . htmlElementSetInnerHTML h =<< sample (current html)
|
||||
addVoidAction $ fmap (liftIO . htmlElementSetInnerHTML h) $ updated html
|
||||
schedulePostBuild $ setInnerHTML e . Just =<< sample (current html)
|
||||
addVoidAction $ fmap (setInnerHTML e . Just) $ updated html
|
||||
wrapElement defaultDomEventHandler e
|
||||
|
||||
data Link t
|
||||
@ -783,7 +793,7 @@ class HasDomEvent t a where
|
||||
domEvent :: EventName en -> a -> Event t (EventResultType en)
|
||||
|
||||
instance Reflex t => HasDomEvent t (El t) where
|
||||
domEvent en e = fmap unEventResult $ select (_el_events e) (WrapArg en)
|
||||
domEvent en e = fmap unEventResult $ Reflex.select (_el_events e) (WrapArg en)
|
||||
|
||||
linkClass :: MonadWidget t m => String -> String -> m (Link t)
|
||||
linkClass s c = do
|
||||
@ -871,7 +881,7 @@ tabDisplay ulClass activeClass tabItems = do
|
||||
unsafePlaceElement :: MonadWidget t m => Element -> m (El t)
|
||||
unsafePlaceElement e = do
|
||||
p <- askParent
|
||||
_ <- liftIO $ nodeAppendChild p $ Just e
|
||||
_ <- appendChild p $ Just e
|
||||
wrapElement defaultDomEventHandler e
|
||||
|
||||
deriveGEq ''EventName
|
||||
|
||||
@ -8,13 +8,13 @@ import Reflex.Dom.Widget.Basic
|
||||
|
||||
import Reflex
|
||||
import Reflex.Host.Class
|
||||
import GHCJS.DOM.HTMLInputElement
|
||||
import GHCJS.DOM.HTMLTextAreaElement
|
||||
import GHCJS.DOM.Element
|
||||
import GHCJS.DOM.HTMLSelectElement
|
||||
import GHCJS.DOM.HTMLInputElement as Input
|
||||
import GHCJS.DOM.HTMLTextAreaElement as TextArea
|
||||
import GHCJS.DOM.Element hiding (error)
|
||||
import GHCJS.DOM.HTMLSelectElement as Select
|
||||
import GHCJS.DOM.EventM
|
||||
import GHCJS.DOM.File
|
||||
import GHCJS.DOM.FileList
|
||||
import qualified GHCJS.DOM.FileList as FileList
|
||||
import Data.Monoid
|
||||
import Data.Map as Map
|
||||
import Control.Lens
|
||||
@ -53,21 +53,21 @@ instance Reflex t => Default (TextInputConfig t) where
|
||||
textInput :: MonadWidget t m => TextInputConfig t -> m (TextInput t)
|
||||
textInput (TextInputConfig inputType initial eSetValue dAttrs) = do
|
||||
e <- liftM castToHTMLInputElement $ buildEmptyElement "input" =<< mapDyn (Map.insert "type" inputType) dAttrs
|
||||
liftIO $ htmlInputElementSetValue e initial
|
||||
performEvent_ $ fmap (liftIO . htmlInputElementSetValue e) eSetValue
|
||||
eChange <- wrapDomEvent e elementOninput $ liftIO $ htmlInputElementGetValue e
|
||||
Input.setValue e $ Just initial
|
||||
performEvent_ $ fmap (Input.setValue e . Just) eSetValue
|
||||
eChange <- wrapDomEvent e (`on` input) $ fromMaybe "" <$> Input.getValue e
|
||||
postGui <- askPostGui
|
||||
runWithActions <- askRunWithActions
|
||||
eChangeFocus <- newEventWithTrigger $ \eChangeFocusTrigger -> do
|
||||
unsubscribeOnblur <- liftIO $ elementOnblur e $ liftIO $ do
|
||||
postGui $ runWithActions [eChangeFocusTrigger :=> False]
|
||||
unsubscribeOnfocus <- liftIO $ elementOnfocus e $ liftIO $ do
|
||||
postGui $ runWithActions [eChangeFocusTrigger :=> True]
|
||||
unsubscribeOnblur <- on e blurEvent $ liftIO $ do
|
||||
postGui $ runWithActions [eChangeFocusTrigger :=> Identity False]
|
||||
unsubscribeOnfocus <- on e focusEvent $ liftIO $ do
|
||||
postGui $ runWithActions [eChangeFocusTrigger :=> Identity True]
|
||||
return $ liftIO $ unsubscribeOnblur >> unsubscribeOnfocus
|
||||
dFocus <- holdDyn False eChangeFocus
|
||||
eKeypress <- wrapDomEvent e elementOnkeypress getKeyEvent
|
||||
eKeydown <- wrapDomEvent e elementOnkeydown getKeyEvent
|
||||
eKeyup <- wrapDomEvent e elementOnkeyup getKeyEvent
|
||||
eKeypress <- wrapDomEvent e (`on` keyPress) getKeyEvent
|
||||
eKeydown <- wrapDomEvent e (`on` keyDown) getKeyEvent
|
||||
eKeyup <- wrapDomEvent e (`on` keyUp) getKeyEvent
|
||||
dValue <- holdDyn initial $ leftmost [eSetValue, eChange]
|
||||
return $ TextInput dValue eChange eKeypress eKeydown eKeyup dFocus e
|
||||
|
||||
@ -97,20 +97,20 @@ data TextArea t
|
||||
textArea :: MonadWidget t m => TextAreaConfig t -> m (TextArea t)
|
||||
textArea (TextAreaConfig initial eSet attrs) = do
|
||||
e <- liftM castToHTMLTextAreaElement $ buildEmptyElement "textarea" attrs
|
||||
liftIO $ htmlTextAreaElementSetValue e initial
|
||||
TextArea.setValue e $ Just initial
|
||||
postGui <- askPostGui
|
||||
runWithActions <- askRunWithActions
|
||||
eChangeFocus <- newEventWithTrigger $ \eChangeFocusTrigger -> do
|
||||
unsubscribeOnblur <- liftIO $ elementOnblur e $ liftIO $ do
|
||||
postGui $ runWithActions [eChangeFocusTrigger :=> False]
|
||||
unsubscribeOnfocus <- liftIO $ elementOnfocus e $ liftIO $ do
|
||||
postGui $ runWithActions [eChangeFocusTrigger :=> True]
|
||||
unsubscribeOnblur <- on e blurEvent $ liftIO $ do
|
||||
postGui $ runWithActions [eChangeFocusTrigger :=> Identity False]
|
||||
unsubscribeOnfocus <- on e focusEvent $ liftIO $ do
|
||||
postGui $ runWithActions [eChangeFocusTrigger :=> Identity True]
|
||||
return $ liftIO $ unsubscribeOnblur >> unsubscribeOnfocus
|
||||
performEvent_ $ fmap (liftIO . htmlTextAreaElementSetValue e) eSet
|
||||
performEvent_ $ fmap (TextArea.setValue e . Just) eSet
|
||||
f <- holdDyn False eChangeFocus
|
||||
ev <- wrapDomEvent e elementOninput $ liftIO $ htmlTextAreaElementGetValue e
|
||||
ev <- wrapDomEvent e (`on` input) $ fromMaybe "" <$> TextArea.getValue e
|
||||
v <- holdDyn initial $ leftmost [eSet, ev]
|
||||
eKeypress <- wrapDomEvent e elementOnkeypress getKeyEvent
|
||||
eKeypress <- wrapDomEvent e (`on` keyPress) getKeyEvent
|
||||
return $ TextArea v ev e f eKeypress
|
||||
|
||||
data CheckboxConfig t
|
||||
@ -135,21 +135,21 @@ checkbox :: MonadWidget t m => Bool -> CheckboxConfig t -> m (Checkbox t)
|
||||
checkbox checked config = do
|
||||
attrs <- mapDyn (\c -> Map.insert "type" "checkbox" $ (if checked then Map.insert "checked" "checked" else Map.delete "checked") c) (_checkboxConfig_attributes config)
|
||||
e <- liftM castToHTMLInputElement $ buildEmptyElement "input" attrs
|
||||
eClick <- wrapDomEvent e elementOnclick $ liftIO $ htmlInputElementGetChecked e
|
||||
performEvent_ $ fmap (\v -> liftIO $ htmlInputElementSetChecked e $! v) $ _checkboxConfig_setValue config
|
||||
eClick <- wrapDomEvent e (`on` click) $ Input.getChecked e
|
||||
performEvent_ $ fmap (\v -> Input.setChecked e $! v) $ _checkboxConfig_setValue config
|
||||
dValue <- holdDyn checked $ leftmost [_checkboxConfig_setValue config, eClick]
|
||||
return $ Checkbox dValue eClick
|
||||
|
||||
checkboxView :: MonadWidget t m => Dynamic t (Map String String) -> Dynamic t Bool -> m (Event t Bool)
|
||||
checkboxView dAttrs dValue = do
|
||||
e <- liftM castToHTMLInputElement $ buildEmptyElement "input" =<< mapDyn (Map.insert "type" "checkbox") dAttrs
|
||||
eClicked <- wrapDomEvent e elementOnclick $ do
|
||||
eClicked <- wrapDomEvent e (`on` click) $ do
|
||||
preventDefault
|
||||
liftIO $ htmlInputElementGetChecked e
|
||||
Input.getChecked e
|
||||
schedulePostBuild $ do
|
||||
v <- sample $ current dValue
|
||||
when v $ liftIO $ htmlInputElementSetChecked e True
|
||||
performEvent_ $ fmap (\v -> liftIO $ htmlInputElementSetChecked e $! v) $ updated dValue
|
||||
when v $ Input.setChecked e True
|
||||
performEvent_ $ fmap (\v -> Input.setChecked e $! v) $ updated dValue
|
||||
return eClicked
|
||||
|
||||
data FileInput t
|
||||
@ -168,10 +168,10 @@ instance Reflex t => Default (FileInputConfig t) where
|
||||
fileInput :: MonadWidget t m => FileInputConfig t -> m (FileInput t)
|
||||
fileInput (FileInputConfig dAttrs) = do
|
||||
e <- liftM castToHTMLInputElement $ buildEmptyElement "input" =<< mapDyn (Map.insert "type" "file") dAttrs
|
||||
eChange <- wrapDomEvent e elementOnchange $ liftIO $ do
|
||||
Just files <- htmlInputElementGetFiles e
|
||||
len <- fileListGetLength files
|
||||
mapM (liftM (fromMaybe (error "fileInput: fileListItem returned null")) . fileListItem files) $ init [0..len]
|
||||
eChange <- wrapDomEvent e (flip on change) $ do
|
||||
Just files <- getFiles e
|
||||
len <- FileList.getLength files
|
||||
mapM (liftM (fromMaybe (error "fileInput: fileListItem returned null")) . FileList.item files) $ init [0..len]
|
||||
dValue <- holdDyn [] eChange
|
||||
return $ FileInput dValue e
|
||||
|
||||
@ -201,9 +201,9 @@ dropdown k0 options (DropdownConfig setK attrs) = do
|
||||
listWithKey optionsWithDefault $ \k v -> do
|
||||
elAttr "option" ("value" =: show k <> if k == k0 then "selected" =: "selected" else mempty) $ dynText v
|
||||
let e = castToHTMLSelectElement $ _el_element eRaw
|
||||
performEvent_ $ fmap (liftIO . htmlSelectElementSetValue e . show) setK
|
||||
eChange <- wrapDomEvent e elementOnchange $ do
|
||||
kStr <- liftIO $ htmlSelectElementGetValue e
|
||||
performEvent_ $ fmap (Select.setValue e . Just . show) setK
|
||||
eChange <- wrapDomEvent e (`on` change) $ do
|
||||
kStr <- fromMaybe "" <$> Select.getValue e
|
||||
return $ readMay kStr
|
||||
let readKey opts mk = fromMaybe k0 $ do
|
||||
k <- mk
|
||||
@ -326,4 +326,3 @@ instance HasStateModeWitness Edit where
|
||||
instance HasStateModeWitness View where
|
||||
stateModeWitness = ViewWitness
|
||||
-}
|
||||
|
||||
|
||||
@ -49,7 +49,7 @@ virtualListWithSelection heightPx rowPx maxIndex i0 setI listTag listAttrs rowTa
|
||||
window <- combineDyn (\h -> findWindow h rowPx) heightPx scrollPosition
|
||||
itemsInWindow <- combineDyn (\(_,(idx,num)) is -> Map.fromList $ map (\i -> let ix = indexToKey i in (ix, Map.lookup ix is)) [idx .. idx + num]) window items
|
||||
postBuild <- getPostBuild
|
||||
performEvent_ $ fmap (\i -> liftIO $ elementSetScrollTop (_el_element container) (i * rowPx)) $ leftmost [setI, fmap (const i0) postBuild]
|
||||
performEvent_ $ fmap (\i -> liftIO $ setScrollTop (_el_element container) (i * rowPx)) $ leftmost [setI, fmap (const i0) postBuild]
|
||||
indexAndLength <- mapDyn snd window
|
||||
return (indexAndLength, sel)
|
||||
where
|
||||
@ -92,7 +92,7 @@ virtualList heightPx rowPx maxIndex i0 setI keyToIndex items0 itemsUpdate itemBu
|
||||
, fmap (const (i0 * rowPx)) pb
|
||||
]
|
||||
window <- combineDyn (\h -> findWindow h rowPx) heightPx scrollPosition
|
||||
performEvent_ $ fmap (\i -> liftIO $ elementSetScrollTop (_el_element viewport) (i * rowPx)) $ leftmost [setI, fmap (const i0) pb]
|
||||
performEvent_ $ fmap (\i -> liftIO $ setScrollTop (_el_element viewport) (i * rowPx)) $ leftmost [setI, fmap (const i0) pb]
|
||||
return (nubDyn window, result)
|
||||
where
|
||||
toStyleAttr m = "style" =: (Map.foldWithKey (\k v s -> k <> ":" <> v <> ";" <> s) "" m)
|
||||
|
||||
@ -8,7 +8,8 @@ import Reflex.Dom.Widget.Basic
|
||||
import Control.Monad
|
||||
import Control.Monad.IO.Class
|
||||
import Data.Monoid
|
||||
import GHCJS.DOM.Element
|
||||
import GHCJS.DOM.Element hiding (reset)
|
||||
import GHCJS.DOM.EventM (on)
|
||||
|
||||
-- | A widget that wraps the given widget in a div and fires an event when resized.
|
||||
-- Adapted from github.com/marcj/css-element-queries
|
||||
@ -31,31 +32,31 @@ resizeDetectorWithStyle styleString w = do
|
||||
let reset = do
|
||||
let e = _el_element expand
|
||||
s = _el_element shrink
|
||||
eow <- elementGetOffsetWidth e
|
||||
eoh <- elementGetOffsetHeight e
|
||||
eow <- getOffsetWidth e
|
||||
eoh <- getOffsetHeight e
|
||||
let ecw = eow + 10
|
||||
ech = eoh + 10
|
||||
elementSetAttribute (_el_element expandChild) "style" (childStyle <> "width: " <> show ecw <> "px;" <> "height: " <> show ech <> "px;")
|
||||
esw <- elementGetScrollWidth e
|
||||
elementSetScrollLeft e esw
|
||||
esh <- elementGetScrollHeight e
|
||||
elementSetScrollTop e esh
|
||||
ssw <- elementGetScrollWidth s
|
||||
elementSetScrollLeft s ssw
|
||||
ssh <- elementGetScrollHeight s
|
||||
elementSetScrollTop s ssh
|
||||
lastWidth <- elementGetOffsetWidth (_el_element parent)
|
||||
lastHeight <- elementGetOffsetHeight (_el_element parent)
|
||||
setAttribute (_el_element expandChild) "style" (childStyle <> "width: " <> show ecw <> "px;" <> "height: " <> show ech <> "px;")
|
||||
esw <- getScrollWidth e
|
||||
setScrollLeft e esw
|
||||
esh <- getScrollHeight e
|
||||
setScrollTop e esh
|
||||
ssw <- getScrollWidth s
|
||||
setScrollLeft s ssw
|
||||
ssh <- getScrollHeight s
|
||||
setScrollTop s ssh
|
||||
lastWidth <- getOffsetWidth (_el_element parent)
|
||||
lastHeight <- getOffsetHeight (_el_element parent)
|
||||
return (Just lastWidth, Just lastHeight)
|
||||
resetIfChanged ds = do
|
||||
pow <- elementGetOffsetWidth (_el_element parent)
|
||||
poh <- elementGetOffsetHeight (_el_element parent)
|
||||
pow <- getOffsetWidth (_el_element parent)
|
||||
poh <- getOffsetHeight (_el_element parent)
|
||||
if ds == (Just pow, Just poh)
|
||||
then return Nothing
|
||||
else liftM Just reset
|
||||
pb <- getPostBuild
|
||||
expandScroll <- wrapDomEvent (_el_element expand) elementOnscroll $ return ()
|
||||
shrinkScroll <- wrapDomEvent (_el_element shrink) elementOnscroll $ return ()
|
||||
expandScroll <- wrapDomEvent (_el_element expand) (`on` scroll) $ return ()
|
||||
shrinkScroll <- wrapDomEvent (_el_element shrink) (`on` scroll) $ return ()
|
||||
size0 <- performEvent $ fmap (const $ liftIO reset) pb
|
||||
rec resize <- performEventAsync $ fmap (\d cb -> liftIO $ cb =<< resetIfChanged d) $ tag (current dimensions) $ leftmost [expandScroll, shrinkScroll]
|
||||
dimensions <- holdDyn (Nothing, Nothing) $ leftmost [ size0, fmapMaybe id resize ]
|
||||
|
||||
@ -1,8 +1,28 @@
|
||||
{-# LANGUAGE TemplateHaskell, GADTs, DeriveDataTypeable #-}
|
||||
module Reflex.Dom.Xhr
|
||||
( module Reflex.Dom.Xhr
|
||||
, XMLHttpRequest
|
||||
, responseTextToText
|
||||
( XMLHttpRequest
|
||||
, XhrRequest(..)
|
||||
, XhrRequestConfig(..)
|
||||
, XhrResponse(..)
|
||||
, XhrResponseBody(..)
|
||||
, XhrResponseType(..)
|
||||
, XhrException(..)
|
||||
, _xhrResponse_body
|
||||
, xhrResponse_body
|
||||
, xhrRequest
|
||||
, newXMLHttpRequest
|
||||
, newXMLHttpRequestWithError
|
||||
, performRequestAsync
|
||||
, performMkRequestAsync
|
||||
, performRequestAsyncWithError
|
||||
, performRequestsAsync
|
||||
, performMkRequestsAsync
|
||||
, performRequestsAsyncWithError
|
||||
, getAndDecode
|
||||
, postJson
|
||||
, getMay
|
||||
, decodeText
|
||||
, decodeXhrResponse
|
||||
, xmlHttpRequestGetReadyState
|
||||
, xmlHttpRequestGetResponseText
|
||||
, xmlHttpRequestGetStatus
|
||||
@ -13,6 +33,18 @@ module Reflex.Dom.Xhr
|
||||
, xmlHttpRequestSend
|
||||
, xmlHttpRequestSetRequestHeader
|
||||
, xmlHttpRequestSetResponseType
|
||||
, xhrRequest_config
|
||||
, xhrRequest_method
|
||||
, xhrRequest_url
|
||||
, xhrRequestConfig_headers
|
||||
, xhrRequestConfig_password
|
||||
, xhrRequestConfig_responseType
|
||||
, xhrRequestConfig_sendData
|
||||
, xhrRequestConfig_user
|
||||
, xhrResponse_response
|
||||
, xhrResponse_responseText
|
||||
, xhrResponse_status
|
||||
, xhrResponse_statusText
|
||||
)
|
||||
where
|
||||
|
||||
@ -21,6 +53,7 @@ import Reflex.Dom.Class
|
||||
import Reflex.Dom.Xhr.Foreign
|
||||
|
||||
import Control.Concurrent
|
||||
import Control.Exception (catch)
|
||||
import Control.Lens
|
||||
import Control.Monad hiding (forM)
|
||||
import Control.Monad.IO.Class
|
||||
@ -36,6 +69,8 @@ import Data.Maybe
|
||||
import Data.Text (Text)
|
||||
import Data.Text.Encoding
|
||||
import Data.Traversable
|
||||
import Reflex.Dom.Xhr.Exception
|
||||
import Reflex.Dom.Xhr.ResponseType
|
||||
import Data.Typeable
|
||||
|
||||
data XhrRequest a
|
||||
@ -49,17 +84,26 @@ data XhrRequestConfig a
|
||||
= XhrRequestConfig { _xhrRequestConfig_headers :: Map String String
|
||||
, _xhrRequestConfig_user :: Maybe String
|
||||
, _xhrRequestConfig_password :: Maybe String
|
||||
, _xhrRequestConfig_responseType :: Maybe String
|
||||
, _xhrRequestConfig_responseType :: Maybe XhrResponseType
|
||||
, _xhrRequestConfig_sendData :: a
|
||||
}
|
||||
deriving (Show, Read, Eq, Ord, Typeable)
|
||||
|
||||
data XhrResponse
|
||||
= XhrResponse { _xhrResponse_body :: Maybe Text
|
||||
, _xhrResponse_status :: Word
|
||||
= XhrResponse { _xhrResponse_status :: Word
|
||||
, _xhrResponse_statusText :: Text
|
||||
, _xhrResponse_response :: Maybe XhrResponseBody
|
||||
, _xhrResponse_responseText :: Maybe Text
|
||||
}
|
||||
deriving (Show, Read, Eq, Ord, Typeable)
|
||||
deriving (Typeable)
|
||||
|
||||
{-# DEPRECATED _xhrResponse_body "Use _xhrResponse_response or _xhrResponse_responseText instead." #-}
|
||||
_xhrResponse_body :: XhrResponse -> Maybe Text
|
||||
_xhrResponse_body = _xhrResponse_responseText
|
||||
|
||||
{-# DEPRECATED xhrResponse_body "Use xhrResponse_response or xhrResponse_responseText instead." #-}
|
||||
xhrResponse_body :: Lens XhrResponse XhrResponse (Maybe Text) (Maybe Text)
|
||||
xhrResponse_body = lens _xhrResponse_responseText (\r t -> r { _xhrResponse_responseText = t })
|
||||
|
||||
instance a ~ () => Default (XhrRequestConfig a) where
|
||||
def = XhrRequestConfig { _xhrRequestConfig_headers = Map.empty
|
||||
@ -73,13 +117,26 @@ instance a ~ () => Default (XhrRequestConfig a) where
|
||||
xhrRequest :: String -> String -> XhrRequestConfig a -> XhrRequest a
|
||||
xhrRequest = XhrRequest
|
||||
|
||||
newXMLHttpRequest :: (HasWebView m, MonadIO m, HasPostGui t h m, IsXhrPayload a) => XhrRequest a -> (XhrResponse -> h ()) -> m XMLHttpRequest
|
||||
newXMLHttpRequest req cb = do
|
||||
-- | Make a new asyncronous XHR request. This does not block (it forks),
|
||||
-- and returns an XHR object immediately (which you can use to abort
|
||||
-- the XHR connection), and will pass an exception ('XhrException') to the
|
||||
-- continuation if the connection cannot be made (or is aborted).
|
||||
newXMLHttpRequestWithError
|
||||
:: (HasWebView m, MonadIO m, HasPostGui t h m, IsXhrPayload a)
|
||||
=> XhrRequest a
|
||||
-- ^ The request to make.
|
||||
-> (Either XhrException XhrResponse -> h ())
|
||||
-- ^ A continuation to be called once a response comes back, or in
|
||||
-- case of error.
|
||||
-> m XMLHttpRequest
|
||||
-- ^ The XHR request, which could for example be aborted.
|
||||
newXMLHttpRequestWithError req cb = do
|
||||
wv <- askWebView
|
||||
postGui <- askPostGui
|
||||
liftIO $ do
|
||||
xhr <- xmlHttpRequestNew $ unWebViewSingleton wv
|
||||
xhr <- liftIO $ xmlHttpRequestNew $ unWebViewSingleton wv
|
||||
void $ liftIO $ forkIO $ flip catch (postGui . cb . Left) $ void $ do
|
||||
let c = _xhrRequest_config req
|
||||
rt = _xhrRequestConfig_responseType c
|
||||
xmlHttpRequestOpen
|
||||
xhr
|
||||
(_xhrRequest_method req)
|
||||
@ -88,32 +145,85 @@ newXMLHttpRequest req cb = do
|
||||
(fromMaybe "" $ _xhrRequestConfig_user c)
|
||||
(fromMaybe "" $ _xhrRequestConfig_password c)
|
||||
iforM_ (_xhrRequestConfig_headers c) $ xmlHttpRequestSetRequestHeader xhr
|
||||
maybe (return ()) (xmlHttpRequestSetResponseType xhr . toResponseType) (_xhrRequestConfig_responseType c)
|
||||
maybe (return ()) (xmlHttpRequestSetResponseType xhr . toResponseType) rt
|
||||
_ <- xmlHttpRequestOnreadystatechange xhr $ do
|
||||
readyState <- liftIO $ xmlHttpRequestGetReadyState xhr
|
||||
status <- liftIO $ xmlHttpRequestGetStatus xhr
|
||||
statusText <- liftIO $ xmlHttpRequestGetStatusText xhr
|
||||
if readyState == 4
|
||||
then do
|
||||
r <- liftIO $ xmlHttpRequestGetResponseText xhr
|
||||
_ <- liftIO $ postGui $ cb $ XhrResponse (responseTextToText r) status (statusTextToText statusText)
|
||||
t <- if rt == Just XhrResponseType_Text || rt == Nothing
|
||||
then liftIO $ xmlHttpRequestGetResponseText xhr
|
||||
else return Nothing
|
||||
r <- liftIO $ xmlHttpRequestGetResponse xhr
|
||||
_ <- liftIO $ postGui $ cb $ Right $
|
||||
XhrResponse { _xhrResponse_status = status
|
||||
, _xhrResponse_statusText = statusText
|
||||
, _xhrResponse_response = r
|
||||
, _xhrResponse_responseText = t
|
||||
}
|
||||
return ()
|
||||
else return ()
|
||||
_ <- xmlHttpRequestSend xhr (_xhrRequestConfig_sendData c)
|
||||
return xhr
|
||||
return ()
|
||||
return xhr
|
||||
|
||||
newXMLHttpRequest :: (HasWebView m, MonadIO m, HasPostGui t h m, IsXhrPayload a) => XhrRequest a -> (XhrResponse -> h ()) -> m XMLHttpRequest
|
||||
newXMLHttpRequest req cb = newXMLHttpRequestWithError req $ mapM_ cb
|
||||
|
||||
-- | Given Event of requests, issue them when the Event fires.
|
||||
-- Returns Event of corresponding responses.
|
||||
--
|
||||
-- The request is processed asynchronously, therefore handling does
|
||||
-- not block or cause a delay while creating the connection.
|
||||
performRequestAsyncWithError
|
||||
:: (MonadWidget t m, IsXhrPayload a)
|
||||
=> Event t (XhrRequest a)
|
||||
-> m (Event t (Either XhrException XhrResponse))
|
||||
performRequestAsyncWithError = performRequestAsync' newXMLHttpRequestWithError . fmap return
|
||||
|
||||
-- | Given Event of request, issue them when the Event fires. Returns Event of corresponding response.
|
||||
performRequestAsync :: (MonadWidget t m, IsXhrPayload a) => Event t (XhrRequest a) -> m (Event t XhrResponse)
|
||||
performRequestAsync req = performEventAsync $ ffor req $ \r cb -> do
|
||||
_ <- newXMLHttpRequest r $ liftIO . cb
|
||||
performRequestAsync = performRequestAsync' newXMLHttpRequest . fmap return
|
||||
|
||||
-- | Given Event with an action that creates a request, build and issue the request when the Event fires. Returns Event of corresponding response.
|
||||
performMkRequestAsync :: (MonadWidget t m, IsXhrPayload a) => Event t (WidgetHost m (XhrRequest a)) -> m (Event t XhrResponse)
|
||||
performMkRequestAsync = performRequestAsync' newXMLHttpRequest
|
||||
|
||||
performRequestAsync' :: (MonadWidget t m, MonadIO h, IsXhrPayload p) => (XhrRequest p -> (a -> h ()) -> WidgetHost m XMLHttpRequest) -> Event t (WidgetHost m (XhrRequest p)) -> m (Event t a)
|
||||
performRequestAsync' newXhr req = performEventAsync $ ffor req $ \hr cb -> do
|
||||
r <- hr
|
||||
newXhr r $ liftIO . cb
|
||||
return ()
|
||||
|
||||
-- | Issues a collection of requests when the supplied Event fires.
|
||||
-- When ALL requests from a given firing complete, the results are
|
||||
-- collected and returned via the return Event.
|
||||
--
|
||||
-- The requests are processed asynchronously, therefore handling does
|
||||
-- not block or cause a delay while creating the connection.
|
||||
--
|
||||
-- Order of request execution and completion is not guaranteed, but
|
||||
-- order of creation and the collection result is preserved.
|
||||
performRequestsAsyncWithError
|
||||
:: (Traversable f, MonadWidget t m, IsXhrPayload a)
|
||||
=> Event t (f (XhrRequest a)) -> m (Event t (f (Either XhrException XhrResponse)))
|
||||
performRequestsAsyncWithError = performRequestsAsync' newXMLHttpRequestWithError . fmap return
|
||||
|
||||
-- | Issues a collection of requests when the supplied Event fires. When ALL requests from a given firing complete, the results are collected and returned via the return Event.
|
||||
performRequestsAsync :: (Traversable f, MonadWidget t m, IsXhrPayload a) => Event t (f (XhrRequest a)) -> m (Event t (f XhrResponse))
|
||||
performRequestsAsync req = performEventAsync $ ffor req $ \rs cb -> do
|
||||
performRequestsAsync = performRequestsAsync' newXMLHttpRequest . fmap return
|
||||
|
||||
-- | Builds and issues a collection of requests when the supplied Event fires. When ALL requests from a given firing complete, the results are collected and returned via the return Event.
|
||||
performMkRequestsAsync :: (Traversable f, MonadWidget t m, IsXhrPayload a) => Event t (WidgetHost m (f (XhrRequest a))) -> m (Event t (f XhrResponse))
|
||||
performMkRequestsAsync = performRequestsAsync' newXMLHttpRequest
|
||||
|
||||
performRequestsAsync' :: (MonadWidget t m, MonadIO h, Traversable f, IsXhrPayload b) => (XhrRequest b -> (a -> h ()) -> WidgetHost m XMLHttpRequest) -> Event t (WidgetHost m (f (XhrRequest b))) -> m (Event t (f a))
|
||||
performRequestsAsync' newXhr req = performEventAsync $ ffor req $ \hrs cb -> do
|
||||
rs <- hrs
|
||||
resps <- forM rs $ \r -> do
|
||||
resp <- liftIO newEmptyMVar
|
||||
_ <- newXMLHttpRequest r $ liftIO . putMVar resp
|
||||
_ <- newXhr r $ liftIO . putMVar resp
|
||||
return resp
|
||||
_ <- liftIO $ forkIO $ cb =<< forM resps takeMVar
|
||||
return ()
|
||||
@ -126,7 +236,7 @@ getAndDecode url = do
|
||||
|
||||
-- | Create a "POST" request from an URL and thing with a JSON representation
|
||||
postJson :: (ToJSON a) => String -> a -> XhrRequest String
|
||||
postJson url a =
|
||||
postJson url a =
|
||||
XhrRequest "POST" url $ def { _xhrRequestConfig_headers = headerUrlEnc
|
||||
, _xhrRequestConfig_sendData = body
|
||||
}
|
||||
@ -143,7 +253,7 @@ decodeText = decode . BL.fromStrict . encodeUtf8
|
||||
|
||||
-- | Convenience function to decode JSON-encoded responses.
|
||||
decodeXhrResponse :: FromJSON a => XhrResponse -> Maybe a
|
||||
decodeXhrResponse = join . fmap decodeText . _xhrResponse_body
|
||||
decodeXhrResponse = join . fmap decodeText . _xhrResponse_responseText
|
||||
|
||||
liftM concat $ mapM makeLenses
|
||||
[ ''XhrRequest
|
||||
|
||||
12
src/Reflex/Dom/Xhr/Exception.hs
Normal file
12
src/Reflex/Dom/Xhr/Exception.hs
Normal file
@ -0,0 +1,12 @@
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
|
||||
module Reflex.Dom.Xhr.Exception where
|
||||
|
||||
import Data.Typeable
|
||||
import Control.Exception (Exception(..))
|
||||
|
||||
data XhrException = XhrException_Error
|
||||
| XhrException_Aborted
|
||||
deriving (Show, Read, Eq, Ord, Typeable)
|
||||
|
||||
instance Exception XhrException
|
||||
14
src/Reflex/Dom/Xhr/ResponseType.hs
Normal file
14
src/Reflex/Dom/Xhr/ResponseType.hs
Normal file
@ -0,0 +1,14 @@
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
|
||||
module Reflex.Dom.Xhr.ResponseType where
|
||||
|
||||
import Data.Typeable
|
||||
|
||||
data XhrResponseType = XhrResponseType_Default
|
||||
| XhrResponseType_ArrayBuffer
|
||||
| XhrResponseType_Blob
|
||||
| XhrResponseType_Document
|
||||
| XhrResponseType_JSON
|
||||
| XhrResponseType_Text
|
||||
deriving (Show, Read, Eq, Ord, Typeable)
|
||||
|
||||
40
test/BrokenHaltSpec.hs
Normal file
40
test/BrokenHaltSpec.hs
Normal file
@ -0,0 +1,40 @@
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
|
||||
module HaltSpec where
|
||||
|
||||
import Control.Monad.IO.Class
|
||||
import Data.Foldable
|
||||
import GHCJS.DOM
|
||||
import qualified Graphics.UI.Gtk as Gtk
|
||||
import Reflex.Dom
|
||||
import Reflex.Spider.Internal (SpiderHostFrame)
|
||||
import Test.Hspec
|
||||
|
||||
spec :: Spec
|
||||
spec = do
|
||||
describe "haltGui" $ do
|
||||
it "works" $ do
|
||||
getFirstEventAndHalt return `shouldReturn` ()
|
||||
|
||||
it "works multiple times" $ do
|
||||
forM_ [1 .. 100] $ \ i -> do
|
||||
getFirstEventAndHalt return `shouldReturn` ()
|
||||
|
||||
type SpiderM =
|
||||
Widget Spider (Gui Spider (WithWebView SpiderHost) SpiderHostFrame)
|
||||
|
||||
getFirstEventAndHalt :: (Event Spider () -> SpiderM (Event Spider ())) -> IO ()
|
||||
getFirstEventAndHalt action = do
|
||||
_ <- mainWidget $ do
|
||||
tick <- getPostBuild
|
||||
event <- action tick
|
||||
webView <- askWebView
|
||||
_ <- foldDynM (\ a () -> liftIO $ haltGui webView) () event
|
||||
return ()
|
||||
return ()
|
||||
|
||||
haltGui :: WebView -> IO ()
|
||||
haltGui wv = do
|
||||
Gtk.postGUIAsync $ do
|
||||
w <- Gtk.widgetGetToplevel wv
|
||||
Gtk.widgetDestroy w
|
||||
29
test/HaltSpec.hs
Normal file
29
test/HaltSpec.hs
Normal file
@ -0,0 +1,29 @@
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
|
||||
import Control.Monad.IO.Class
|
||||
import Data.Foldable
|
||||
import GHCJS.DOM
|
||||
import qualified Graphics.UI.Gtk as Gtk
|
||||
import Reflex.Dom
|
||||
import Reflex.Spider.Internal (SpiderHostFrame)
|
||||
|
||||
main = do
|
||||
getFirstEventAndHalt return
|
||||
putStrLn "stopped once"
|
||||
|
||||
forM_ [1 .. 1000] $ \ i -> do
|
||||
getFirstEventAndHalt return
|
||||
putStrLn "stopped many times"
|
||||
|
||||
type SpiderM = Widget Spider (Gui Spider (WithWebView SpiderHost) SpiderHostFrame)
|
||||
|
||||
getFirstEventAndHalt :: (Event Spider () -> SpiderM (Event Spider ())) -> IO ()
|
||||
getFirstEventAndHalt action = do
|
||||
_ <- mainWidget $ do
|
||||
tick <- getPostBuild
|
||||
event <- action tick
|
||||
webView <- askWebView
|
||||
quit <- getQuitWidget
|
||||
performEvent_ (quit <$ event)
|
||||
return ()
|
||||
return ()
|
||||
Loading…
Reference in New Issue
Block a user