5903797 · reflex-dom · git.iko.soy

git.iko.soy/reflex-dom

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

commit59037976317e7decd8c245f108d1c1fe83d345bf authorRyan Trinkle <ryan.trinkle@gmail.com> dateSat 23 Jan 2016, 01:19 (11 years ago) parent6f95896

21 files changed+788−736

compare with develop

unifiedsplit

default.nix+3−3

@@ -3,12 +3,12 @@

33, transformers, data-default, semigroups, aeson

44, ghc, webkitgtk3-javascriptcore, exception-transformers

55, webkitgtk24x, dependent-sum-template, bifunctors, zenc

6−, random

6+, random, raw-strings-qq

77}:

99mkDerivation {

1010 pname = "reflex-dom";

11− version = "0.2";

11+ version = "0.3";

1212 src = builtins.filterSource (path: type: baseNameOf path != ".git") ./.;

1313 buildDepends = [

1414 reflex

@@ -29,7 +29,7 @@ mkDerivation {

2929 bifunctors

3030 zenc

3131 random

32− ] ++ (if (ghc.pname or null) == "ghcjs" then [ ] else [ webkitgtk3-javascriptcore ]);

32+ ] ++ (if (ghc.pname or null) == "ghcjs" then [ ] else [ webkitgtk3-javascriptcore raw-strings-qq ]);

3333 pkgconfigDepends = if (ghc.pname or null) == "ghcjs" then [ ] else [ webkitgtk24x ];

3434 license = null;

3535}

reflex-dom.cabal+18−12

@@ -1,5 +1,5 @@

11Name: reflex-dom

2−Version: 0.2

2+Version: 0.3

33Synopsis: Functional Reactive Web Apps with Reflex

44Description: Reflex-DOM is a Functional Reactive web framework based on the Reflex FRP engine

55License: BSD3

@@ -15,24 +15,26 @@ extra-source-files: src-ghc/Reflex/Dom/Internal/Foreign.hs

1515 src-ghc/Reflex/Dom/Xhr/Foreign.hs

1616 src-ghcjs/Reflex/Dom/Internal/Foreign.hs

1717 src-ghcjs/Reflex/Dom/Xhr/Foreign.hs

18+ src/Reflex/Dom/Xhr/ResponseType.hs

19+ src/Reflex/Dom/Xhr/Exception.hs

1820

1921library

2022 hs-source-dirs: src

2123 build-depends:

2224 base >= 4.7 && < 4.9,

2325 template-haskell,

24− reflex == 0.3.*,

25− dependent-sum == 0.2.*,

26− dependent-map == 0.1.*,

27− semigroups == 0.16.*,

26+ reflex == 0.4.*,

27+ dependent-sum == 0.3.*,

28+ dependent-map == 0.2.*,

29+ semigroups >= 0.16 && < 0.19,

2830 mtl >= 2.1 && < 2.3,

2931 containers == 0.5.*,

3032 these >= 0.4 && < 0.7,

3133 ref-tf == 0.4.*,

3234 random == 1.1.*,

35+ ghcjs-dom >= 0.2.1 && < 0.3,

3336 transformers == 0.3.* || == 0.4.*,

3437 lens >= 4.7 && < 4.14,

35− ghcjs-dom >= 0.1.1.3 && < 0.2,

3638 safe == 0.3.*,

3739 text == 1.2.*,

3840 bytestring == 0.10.*,

@@ -43,11 +45,10 @@ library

4345 directory == 1.2.*,

4446 dependent-sum-template >= 0.0.0.4 && < 0.1,

4547 zenc == 0.1.*,

46− bifunctors >= 4.2 && < 5.1

48+ bifunctors >= 4.2 && < 6

4749

4850 if impl(ghcjs)

4951 hs-source-dirs: src-ghcjs

50− cpp-options: -D__GHCJS__

5152 build-depends:

5253 ghcjs-base,

5354 hashable == 1.2.*

@@ -55,11 +56,14 @@ library

5556 hs-source-dirs: src-ghc

5657 build-depends:

5758 glib == 0.13.*,

58− gtk3 == 0.13.*,

59− webkitgtk3 == 0.13.*,

60− webkitgtk3-javascriptcore == 0.13.*

59+ gtk3 >= 0.13.0 && < 0.15,

60+ webkitgtk3 == 0.14.*,

61+ webkitgtk3-javascriptcore == 0.13.*,

62+ raw-strings-qq

6163 pkgconfig-depends:

6264 webkitgtk-3.0 >= 1.8

65+ if !os(windows)

66+ build-depends: unix == 2.7.*

6367

6468 exposed-modules:

6569 Reflex.Dom

@@ -80,9 +84,11 @@ library

8084 Reflex.Dom.Internal.Foreign

8185 Reflex.Dom.WebSocket.Foreign

8286 Reflex.Dom.Xhr.Foreign

87+ Reflex.Dom.Xhr.ResponseType

88+ Reflex.Dom.Xhr.Exception

8389

8490 other-extensions: TemplateHaskell

85− ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2

91+ ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 -ferror-spans

8692

8793source-repository head

8894 type: git

src-ghc/Reflex/Dom/Internal/Foreign.hs+21−5

@@ -1,4 +1,4 @@

1−{-# LANGUAGE ForeignFunctionInterface #-}

1+{-# LANGUAGE CPP, ForeignFunctionInterface, ScopedTypeVariables, LambdaCase #-}

22module Reflex.Dom.Internal.Foreign where

44import Control.Lens hiding (set)

@@ -7,7 +7,7 @@ import Control.Concurrent

77import Control.Monad.State.Strict hiding (mapM, mapM_, forM, forM_, sequence, sequence_, get)

88import Foreign.Ptr

99import GHCJS.DOM.Navigator

10−import GHCJS.DOM.DOMWindow

10+import GHCJS.DOM.Window

1111import Graphics.UI.Gtk hiding (Widget)

1212import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSBase

1313import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSObjectRef

@@ -15,7 +15,7 @@ import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSStringRef

1515import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSValueRef

1616import Graphics.UI.Gtk.WebKit.JavaScriptCore.WebFrame

1717import Graphics.UI.Gtk.WebKit.WebView

18−import Graphics.UI.Gtk.WebKit.Types hiding (Event, Widget, unWidget)

18+import Graphics.UI.Gtk.WebKit.Types hiding (Event, Widget)

1919import Graphics.UI.Gtk.WebKit.WebSettings

2020import Graphics.UI.Gtk.WebKit.WebFrame

2121import Graphics.UI.Gtk.WebKit.WebInspector

@@ -23,6 +23,21 @@ import Data.List

2323import System.Directory

2424import System.Glib.FFI hiding (void)

2525

26+#ifndef mingw32_HOST_OS

27+import System.Posix.Signals

28+#endif

29+

30+quitWebView :: WebView -> IO ()

31+quitWebView wv = postGUIAsync $ do w <- widgetGetToplevel wv

32+ widgetDestroy w

33+

34+installQuitHandler :: WebView -> IO ()

35+#ifdef mingw32_HOST_OS

36+installQuitHandler wv = return () -- TODO: Maybe figure something out here for Windows users.

37+#else

38+installQuitHandler wv = installHandler keyboardSignal (Catch (quitWebView wv)) Nothing >> return ()

39+#endif

40+

2641makeDefaultWebView :: String -> (WebView -> IO ()) -> IO ()

2742makeDefaultWebView userAgentKey main = do

2843 _ <- initGUI

@@ -58,6 +73,7 @@ makeDefaultWebView userAgentKey main = do

5873 wf <- webViewGetMainFrame webView

5974 pwd <- getCurrentDirectory

6075 webFrameLoadString wf "" Nothing $ "file://" ++ pwd ++ "/"

76+ installQuitHandler webView

6177 mainGUI

6278

6379runWebGUI :: (WebView -> IO ()) -> IO ()

@@ -70,8 +86,8 @@ runWebGUI' userAgentKey main = do

7086 case mbWindow of

7187 Just window -> do

7288 -- Check if we are running in javascript inside the the native version

73− Just n <- domWindowGetNavigator window

74− agent <- navigatorGetUserAgent n

89+ Just n <- getNavigator window

90+ agent <- getUserAgent n

7591 unless ((" " ++ userAgentKey) `isSuffixOf` agent) $ main (castToWebView window)

7692 Nothing -> do

7793 makeDefaultWebView userAgentKey main

src-ghc/Reflex/Dom/Xhr/Foreign.hs+82−27

@@ -1,7 +1,8 @@

1−{-# LANGUAGE ForeignFunctionInterface, TypeSynonymInstances, FlexibleInstances #-}

2−module Reflex.Dom.Xhr.Foreign where

1+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, QuasiQuotes, ForeignFunctionInterface #-}

2+module Reflex.Dom.Xhr.Foreign ( module Reflex.Dom.Xhr.Foreign

3+ , XhrResponseType

4+ ) where

4−import Control.Lens.Indexed

56import qualified Data.Text as T

67import Data.Text (Text)

78import System.Glib.FFI

@@ -12,26 +13,33 @@ import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSStringRef

1213import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSValueRef

1314import Graphics.UI.Gtk.WebKit.JavaScriptCore.WebFrame

1415import GHCJS.DOM.File

16+import Reflex.Dom.Xhr.ResponseType

17+import Reflex.Dom.Xhr.Exception

18+import Control.Concurrent.MVar

19+import Control.Exception.Base

1520

1621import Reflex.Dom.Internal.Foreign

1722

23+import Text.RawString.QQ

24+

1825data XMLHttpRequest

1926 = XMLHttpRequest { xhrValue :: JSValueRef

2027 , xhrContext :: JSContextRef --TODO: Get rid of this

2128 }

2229 deriving (Eq, Ord)

2330

24−responseTextToText :: Maybe String -> Maybe Text

25−responseTextToText = fmap T.pack

26−

27−statusTextToText :: String -> Text

28−statusTextToText = T.pack

31+data XhrResponseBody = XhrResponseBody { unXhrResponseBody :: JSValueRef }

2932

3033stringToJSValue :: JSContextRef -> String -> IO JSValueRef

3134stringToJSValue ctx s = jsvaluemakestring ctx =<< jsstringcreatewithutf8cstring s

3235

33−toResponseType :: a -> a

34−toResponseType = id

36+toResponseType :: XhrResponseType -> String

37+toResponseType XhrResponseType_Default = ""

38+toResponseType XhrResponseType_ArrayBuffer = "arraybuffer"

39+toResponseType XhrResponseType_Blob = "blob"

40+toResponseType XhrResponseType_Document = "document"

41+toResponseType XhrResponseType_JSON = "json"

42+toResponseType XhrResponseType_Text = "text"

3543

3644xmlHttpRequestNew :: WebView -> IO XMLHttpRequest

3745xmlHttpRequestNew wv = do

@@ -75,7 +83,17 @@ xmlHttpRequestGetReadyState xhr = do

7583 d <- jsvaluetonumber c rs nullPtr

7684 return $ truncate d

7785

78−xmlHttpRequestGetResponseText :: XMLHttpRequest -> IO (Maybe String)

86+xmlHttpRequestGetResponse :: XMLHttpRequest -> IO (Maybe XhrResponseBody)

87+xmlHttpRequestGetResponse xhr = do

88+ let c = xhrContext xhr

89+ script <- jsstringcreatewithutf8cstring "this.response"

90+ t <- jsevaluatescript c script (xhrValue xhr) nullPtr 1 nullPtr

91+ isNull <- jsvalueisnull c t

92+ case isNull of

93+ True -> return Nothing

94+ False -> return $ Just $ XhrResponseBody t

95+

96+xmlHttpRequestGetResponseText :: XMLHttpRequest -> IO (Maybe Text)

7997xmlHttpRequestGetResponseText xhr = do

8098 let c = xhrContext xhr

8199 script <- jsstringcreatewithutf8cstring "this.responseText"

@@ -89,7 +107,7 @@ xmlHttpRequestGetResponseText xhr = do

89107 s <- allocaBytes (fromIntegral l) $ \ps -> do

90108 _ <- jsstringgetutf8cstring'_ j ps (fromIntegral l)

91109 peekCString ps

92− return $ Just s

110+ return $ Just $ T.pack s

93111

94112class IsXhrPayload a where

95113 xmlHttpRequestSend :: XMLHttpRequest -> a -> IO ()

@@ -106,19 +124,56 @@ instance IsXhrPayload File where

106124xmlHttpRequestSendPayload :: XMLHttpRequest -> Maybe String -> IO ()

107125xmlHttpRequestSendPayload xhr payload = do

108126 let c = xhrContext xhr

109− (o,s) <- case payload of

110− Nothing -> do

111− o <- toJSObject c [xhrValue xhr]

112− s <- jsstringcreatewithutf8cstring "this[0].send();"

113− return (o,s)

114− Just payload' -> do

115− d <- stringToJSValue c payload'

116− o <- toJSObject c [xhrValue xhr, d]

117− s <- jsstringcreatewithutf8cstring "this[0].send(this[1])"

118− return (o,s)

119− _ <- jsevaluatescript c s o nullPtr 1 nullPtr

120− return ()

121−

127+ result <- newEmptyMVar

128+ let wrapper' x = wrapper $ \_ _ _ _ _ _ -> putMVar result x >> jsvaluemakeundefined c

129+ bracket (wrapper' $ Just XhrException_Aborted) freeHaskellFunPtr $ \a -> do

130+ onAbort <- jsobjectmakefunctionwithcallback c nullPtr a

131+ bracket (wrapper' $ Just XhrException_Error) freeHaskellFunPtr $ \e -> do

132+ onError <- jsobjectmakefunctionwithcallback c nullPtr e

133+ bracket (wrapper' Nothing) freeHaskellFunPtr $ \l -> do

134+ onLoad <- jsobjectmakefunctionwithcallback c nullPtr l

135+ (o,s) <- case payload of

136+ Nothing -> do

137+ d <- jsvaluemakeundefined c

138+ o <- toJSObject c [xhrValue xhr, d, onError, onAbort, onLoad]

139+ s <- jsstringcreatewithutf8cstring send

140+ return (o,s)

141+ Just payload' -> do

142+ d <- stringToJSValue c payload'

143+ o <- toJSObject c [xhrValue xhr, d, onError, onAbort, onLoad]

144+ s <- jsstringcreatewithutf8cstring send

145+ return (o,s)

146+ _ <- jsevaluatescript c s o nullPtr 1 nullPtr

147+ takeMVar result >>= mapM_ throwIO

148+ where

149+ send = [r|

150+ (function (xhr, d, onError, onAbort, onLoad) {

151+ var clear;

152+ var error = function () {

153+ clear(); onError();

154+ };

155+ var abort = function () {

156+ clear(); onAbort();

157+ };

158+ var load = function () {

159+ clear(); onLoad();

160+ };

161+ clear = function () {

162+ xhr.removeEventListener('error', error);

163+ xhr.removeEventListener('abort', abort);

164+ xhr.removeEventListener('load', load);

165+ }

166+ xhr.addEventListener('error', error);

167+ xhr.addEventListener('abort', abort);

168+ xhr.addEventListener('load', load);

169+ if(d) {

170+ xhr.send(d);

171+ } else {

172+ xhr.send();

173+ }

174+ })(this[0], this[1], this[2], this[3], this[4])

175+ |]

176+

122177xmlHttpRequestSetRequestHeader :: XMLHttpRequest -> String -> String -> IO ()

123178xmlHttpRequestSetRequestHeader xhr header value = do

124179 let c = xhrContext xhr

@@ -146,7 +201,7 @@ xmlHttpRequestGetStatus xhr = do

146201 d <- jsvaluetonumber c s nullPtr

147202 return $ truncate d

148203

149−xmlHttpRequestGetStatusText :: XMLHttpRequest -> IO String

204+xmlHttpRequestGetStatusText :: XMLHttpRequest -> IO Text

150205xmlHttpRequestGetStatusText xhr = do

151206 let c = xhrContext xhr

152207 script <- jsstringcreatewithutf8cstring "this.statusText"

@@ -156,4 +211,4 @@ xmlHttpRequestGetStatusText xhr = do

156211 s <- allocaBytes (fromIntegral l) $ \ps -> do

157212 _ <- jsstringgetutf8cstring'_ j ps (fromIntegral l)

158213 peekCString ps

159− return s

214+ return $ T.pack s

src-ghcjs/Reflex/Dom/Internal/Foreign.hs+7−14

@@ -1,29 +1,22 @@

1−{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI, CPP #-}

2−

3−module Reflex.Dom.Internal.Foreign ( runWebGUI

4− , module Reflex.Dom.Internal.Foreign

1+{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI #-}

2+module Reflex.Dom.Internal.Foreign ( module Reflex.Dom.Internal.Foreign

3+ , runWebGUI

54 ) where

76import Control.Monad

87import GHCJS.DOM

98import GHCJS.DOM.Types

109import GHCJS.Types

11−import Data.Function

12−import GHCJS.Foreign

13−

14−#define JS(name, js, type) foreign import javascript unsafe js name :: type

1510

16−instance Eq Node where

17− (==) = eqRef `on` unNode

11+quitWebView :: WebView -> IO ()

12+quitWebView = error "quitWebView: unimplemented in GHCJS"

1813

19−JS(getLocationHost_, "location.host", IO JSString)

14+foreign import javascript unsafe "location['host']" getLocationHost_ :: IO JSString

2015

2116getLocationHost :: FromJSString r => a -> IO r

2217getLocationHost _ = liftM fromJSString getLocationHost_

2318

24−JS(getLocationProtocol_, "location.protocol", IO JSString)

19+foreign import javascript unsafe "location['protocol']" getLocationProtocol_ :: IO JSString

2520

2621getLocationProtocol :: FromJSString r => a -> IO r

2722getLocationProtocol _ = liftM fromJSString getLocationProtocol_

28−

29−

src-ghcjs/Reflex/Dom/WebSocket/Foreign.hs+31−31

@@ -1,44 +1,44 @@

1−{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI, CPP, TemplateHaskell, NoMonomorphismRestriction, EmptyDataDecls, RankNTypes, GADTs, RecursiveDo, ScopedTypeVariables, FlexibleInstances, MultiParamTypeClasses, TypeFamilies, FlexibleContexts, DeriveDataTypeable, GeneralizedNewtypeDeriving, StandaloneDeriving, ConstraintKinds, UndecidableInstances, PolyKinds, AllowAmbiguousTypes #-}

1+{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI, CPP #-}

33module Reflex.Dom.WebSocket.Foreign where

55import Prelude hiding (div, span, mapM, mapM_, concat, concatMap, all, sequence)

7−import Control.Monad hiding (forM, forM_, mapM, mapM_, sequence)

87import Data.ByteString (ByteString)

9−import Data.Text.Encoding

108import qualified Data.ByteString as BS

11−import Foreign.Ptr

12−import GHCJS.Foreign

13−import GHCJS.Marshal

149import GHCJS.Types

15−import GHCJS.DOM.EventM

10+import GHCJS.DOM.WebSocket (message, open, closeEvent)

11+import qualified GHCJS.DOM.WebSocket as GD

12+import GHCJS.DOM.MessageEvent

13+import GHCJS.DOM.EventM (on)

1614import GHCJS.DOM.Types

15+import Control.Monad.IO.Class

16+import Control.Monad.Reader

17+import GHCJS.Buffer

18+import JavaScript.TypedArray.ArrayBuffer as JS

19+import GHCJS.Marshal.Pure

1720

18−#define JS(name, js, type) foreign import javascript unsafe js name :: type

19−

20−newtype JSWebSocket = JSWebSocket { unJSWebSocket :: JSRef JSWebSocket }

21−

22−data JSByteArray

23−JS(extractByteArray, "new Uint8Array($1_1.buf, $1_2, $2)", Ptr a -> Int -> IO (JSRef JSByteArray))

24−

25−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))

26−

27−JS(webSocketSend_, "$1['send'](String.fromCharCode.apply(null, $2))", JSRef JSWebSocket -> JSRef JSByteArray -> IO ())

28−

29−webSocketSend :: JSWebSocket -> ByteString -> IO ()

30−webSocketSend ws bs = BS.useAsCString bs $ \cStr -> do

31− ba <- extractByteArray cStr $ BS.length bs

32− webSocketSend_ (unJSWebSocket ws) ba

21+data JSWebSocket = JSWebSocket { unWebSocket :: WebSocket }

3322

3423newWebSocket :: a -> String -> (ByteString -> IO ()) -> IO () -> IO () -> IO JSWebSocket

3524newWebSocket _ url onMessage onOpen onClose = do

36− onMessageFun <- syncCallback1 AlwaysRetain True $ onMessage <=< return . encodeUtf8 . fromJSString

37− rec onCloseFun <- syncCallback AlwaysRetain True $ do

38− release onMessageFun

39− release onCloseFun

40− onClose

41− onOpenFun <- syncCallback AlwaysRetain True $ do

42− release onOpenFun

43− onOpen

44− liftM JSWebSocket $ newWebSocket_ (toJSString url) onMessageFun onOpenFun onCloseFun

25+ ws <- GD.newWebSocket url (Just [] :: Maybe [String])

26+ _ <- on ws open $ liftIO onOpen

27+ GD.setBinaryType ws "arraybuffer"

28+ _ <- on ws message $ do

29+ e <- ask

30+ d <- getData e

31+ ab <- liftIO $ unsafeFreeze $ pFromJSVal d

32+ liftIO $ onMessage $ toByteString 0 Nothing $ createFromArrayBuffer ab

33+ _ <- on ws closeEvent $ liftIO onClose

34+ return $ JSWebSocket ws

35+

36+webSocketSend :: JSWebSocket -> ByteString -> IO ()

37+webSocketSend (JSWebSocket ws) bs = do

38+ let (b, off, len) = fromByteString bs

39+ ab <- ArrayBuffer <$> if BS.length bs == 0 --TODO: remove this logic when https://github.com/ghcjs/ghcjs-base/issues/49 is fixed

40+ then jsval . getArrayBuffer <$> create 0

41+ else return $ js_dataView off len $ jsval $ getArrayBuffer b

42+ GD.send ws $ Just ab

43+

44+foreign import javascript safe "new DataView($3,$1,$2)" js_dataView :: Int -> Int -> JSVal -> JSVal

src-ghcjs/Reflex/Dom/Xhr/Foreign.hs+123−369

@@ -1,406 +1,160 @@

1−{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI, FlexibleInstances #-}

1+{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI, OverloadedStrings, FlexibleInstances #-}

3−module Reflex.Dom.Xhr.Foreign where

3+module Reflex.Dom.Xhr.Foreign (

4+ XMLHttpRequest

5+ , XMLHttpRequestResponseType(..)

6+ , module Reflex.Dom.Xhr.Foreign

7+) where

5−import GHCJS.Types

6−import GHCJS.Foreign

7−import GHCJS.Marshal

8−import qualified Data.Text as T

9+import Prelude hiding (error)

910import Data.Text (Text)

1011import GHCJS.DOM.Types hiding (Text)

1112import GHCJS.DOM.EventM

1213import GHCJS.DOM

13−import Data.Function

14−import Control.Monad

14+import GHCJS.DOM.Enums

15+import GHCJS.DOM.XMLHttpRequest

16+import Data.Maybe (fromMaybe)

17+import GHCJS.DOM.EventTarget (dispatchEvent)

18+import GHCJS.Types

19+import Reflex.Dom.Xhr.Exception

20+import Reflex.Dom.Xhr.ResponseType

21+import Control.Exception (catch, throwIO)

22+

23+data XhrResponseBody = XhrResponseBody { unXhrResponseBody :: JSVal }

1524

1625prepareWebView :: WebView -> IO ()

1726prepareWebView _ = return ()

1827

19−foreign import javascript unsafe "h$isInstanceOf $1 $2"

20− typeInstanceIsA' :: JSRef a -> JSRef GType -> Bool

28+xmlHttpRequestNew :: a -> IO XMLHttpRequest

29+xmlHttpRequestNew _ = newXMLHttpRequest

2130

22−typeInstanceIsA :: JSRef a -> GType -> Bool

23−typeInstanceIsA o (GType t) = typeInstanceIsA' o t

31+xmlHttpRequestOpen ::

32+ (ToJSString method, ToJSString url, ToJSString user, ToJSString password) =>

33+ XMLHttpRequest -> method -> url -> Bool -> user -> password -> IO ()

34+xmlHttpRequestOpen = open

2435

25−castTo :: (GObjectClass obj, GObjectClass obj') => GType -> String

26− -> (obj -> obj')

27−castTo gtype objTypeName obj =

28− case toGObject obj of

29− gobj@(GObject objRef)

30− | typeInstanceIsA objRef gtype

31− -> unsafeCastGObject gobj

32− | otherwise -> error $ "Cannot cast object to " ++ objTypeName

36+convertException :: XHRError -> XhrException

37+convertException e = case e of

38+ XHRError -> XhrException_Error

39+ XHRAborted -> XhrException_Aborted

3340

34−newtype XMLHttpRequest = XMLHttpRequest { unXMLHttpRequest :: JSRef XMLHttpRequest }

41+class IsXhrPayload a where

42+ sendXhrPayload :: XMLHttpRequest -> a -> IO ()

3543

36−instance Eq XMLHttpRequest where

37− (==) = eqRef `on` unXMLHttpRequest

44+instance IsXhrPayload () where

45+ sendXhrPayload xhr _ = send xhr

3846

39−instance ToJSRef XMLHttpRequest where

40− toJSRef = return . unXMLHttpRequest

41− {-# INLINE toJSRef #-}

47+instance IsXhrPayload String where

48+ sendXhrPayload = sendString

4249

43−instance FromJSRef XMLHttpRequest where

44− fromJSRef = return . fmap XMLHttpRequest . maybeJSNull

45− {-# INLINE fromJSRef #-}

50+instance IsXhrPayload FormData where

51+ sendXhrPayload = sendFormData

4652

47−class GObjectClass o => IsXMLHttpRequest o

48−toXMLHttpRequest :: IsXMLHttpRequest o => o -> XMLHttpRequest

49−toXMLHttpRequest = unsafeCastGObject . toGObject

53+instance IsXhrPayload Document where

54+ sendXhrPayload = sendDocument

5055

51−instance IsXMLHttpRequest XMLHttpRequest

52−instance GObjectClass XMLHttpRequest where

53− toGObject = GObject . castRef . unXMLHttpRequest

54− unsafeCastGObject = XMLHttpRequest . castRef . unGObject

56+instance IsXhrPayload Blob where

57+ sendXhrPayload = sendBlob

5558

56−castToXMLHttpRequest :: GObjectClass obj => obj -> XMLHttpRequest

57−castToXMLHttpRequest = castTo gTypeXMLHttpRequest "XMLHttpRequest"

59+newtype XhrPayload = XhrPayload { unXhrPayload :: JSVal }

5860

59−foreign import javascript unsafe "window[\"XMLHttpRequest\"]" gTypeXMLHttpRequest' :: JSRef GType

60−gTypeXMLHttpRequest :: GType

61−gTypeXMLHttpRequest = GType gTypeXMLHttpRequest'

61+-- This used to be a non blocking call, but now it uses an interruptible ffi

62+xmlHttpRequestSend :: IsXhrPayload payload => XMLHttpRequest -> payload -> IO ()

63+xmlHttpRequestSend self p = sendXhrPayload self p `catch` (throwIO . convertException)

6264

65+xmlHttpRequestSetRequestHeader :: (ToJSString header, ToJSString value)

66+ => XMLHttpRequest -> header -> value -> IO ()

67+xmlHttpRequestSetRequestHeader = setRequestHeader

6368

64−newtype XMLHttpRequestUpload = XMLHttpRequestUpload { unXMLHttpRequestUpload :: JSRef XMLHttpRequestUpload }

69+xmlHttpRequestAbort :: XMLHttpRequest -> IO ()

70+xmlHttpRequestAbort = abort

6571

66−instance Eq XMLHttpRequestUpload where

67− (==) = eqRef `on` unXMLHttpRequestUpload

72+xmlHttpRequestGetAllResponseHeaders :: XMLHttpRequest -> IO Text

73+xmlHttpRequestGetAllResponseHeaders self = fromMaybe "" <$> getAllResponseHeaders self

6874

69−instance ToJSRef XMLHttpRequestUpload where

70− toJSRef = return . unXMLHttpRequestUpload

71− {-# INLINE toJSRef #-}

75+xmlHttpRequestGetResponseHeader :: (ToJSString header)

76+ => XMLHttpRequest -> header -> IO Text

77+xmlHttpRequestGetResponseHeader self header = fromMaybe "" <$> getResponseHeader self header

7278

73−instance FromJSRef XMLHttpRequestUpload where

74− fromJSRef = return . fmap XMLHttpRequestUpload . maybeJSNull

75− {-# INLINE fromJSRef #-}

79+xmlHttpRequestOverrideMimeType :: ToJSString override => XMLHttpRequest -> override -> IO ()

80+xmlHttpRequestOverrideMimeType = overrideMimeType

7681

77−class GObjectClass o => IsXMLHttpRequestUpload o

78−toXMLHttpRequestUpload :: IsXMLHttpRequestUpload o => o -> XMLHttpRequestUpload

79−toXMLHttpRequestUpload = unsafeCastGObject . toGObject

82+xmlHttpRequestDispatchEvent :: IsEvent evt => XMLHttpRequest -> Maybe evt -> IO Bool

83+xmlHttpRequestDispatchEvent = dispatchEvent

8084

81−instance IsXMLHttpRequestUpload XMLHttpRequestUpload

82−instance GObjectClass XMLHttpRequestUpload where

83− toGObject = GObject . castRef . unXMLHttpRequestUpload

84− unsafeCastGObject = XMLHttpRequestUpload . castRef . unGObject

85+xmlHttpRequestOnabort :: XMLHttpRequest -> EventM XMLHttpRequest XMLHttpRequestProgressEvent () -> IO (IO ())

86+xmlHttpRequestOnabort = (`on` abortEvent)

8587

86−castToXMLHttpRequestUpload :: GObjectClass obj => obj -> XMLHttpRequestUpload

87−castToXMLHttpRequestUpload = castTo gTypeXMLHttpRequestUpload "XMLHttpRequestUpload"

88+xmlHttpRequestOnerror :: XMLHttpRequest -> EventM XMLHttpRequest XMLHttpRequestProgressEvent () -> IO (IO ())

89+xmlHttpRequestOnerror = (`on` error)

8890

89−foreign import javascript unsafe "window[\"XMLHttpRequestUpload\"]" gTypeXMLHttpRequestUpload' :: JSRef GType

90−gTypeXMLHttpRequestUpload :: GType

91−gTypeXMLHttpRequestUpload = GType gTypeXMLHttpRequestUpload'

91+xmlHttpRequestOnload :: XMLHttpRequest -> EventM XMLHttpRequest XMLHttpRequestProgressEvent () -> IO (IO ())

92+xmlHttpRequestOnload = (`on` load)

9293

93−foreign import javascript unsafe "new XMLHttpRequest()"

94− ghcjs_dom_xml_http_request_new ::

95− IO (JSRef XMLHttpRequest)

94+xmlHttpRequestOnloadend :: XMLHttpRequest -> EventM XMLHttpRequest ProgressEvent () -> IO (IO ())

95+xmlHttpRequestOnloadend = (`on` loadEnd)

9696

97−xmlHttpRequestNew :: a -> IO XMLHttpRequest

98−xmlHttpRequestNew _ = XMLHttpRequest <$> ghcjs_dom_xml_http_request_new

97+xmlHttpRequestOnloadstart :: XMLHttpRequest -> EventM XMLHttpRequest ProgressEvent () -> IO (IO ())

98+xmlHttpRequestOnloadstart = (`on` loadStart)

9999

100−foreign import javascript unsafe "$1[\"open\"]($2, $3, $4, $5, $6)"

101− ghcjs_dom_xml_http_request_open ::

102− JSRef XMLHttpRequest -> JSString -> JSString -> JSBool -> JSString -> JSString -> IO ()

100+xmlHttpRequestOnprogress :: XMLHttpRequest -> EventM XMLHttpRequest XMLHttpRequestProgressEvent () -> IO (IO ())

101+xmlHttpRequestOnprogress = (`on` progress)

103102

104−xmlHttpRequestOpen ::

105− (IsXMLHttpRequest self, ToJSString method, ToJSString url, ToJSString user, ToJSString password) =>

106− self -> method -> url -> Bool -> user -> password -> IO ()

107−xmlHttpRequestOpen self method url async user password

108− = ghcjs_dom_xml_http_request_open

109− (unXMLHttpRequest (toXMLHttpRequest self))

110− (toJSString method)

111− (toJSString url)

112− (toJSBool async)

113− (toJSString user)

114− (toJSString password)

115−

116−foreign import javascript unsafe "($2===null)?$1[\"send\"]():$1[\"send\"]($2)"

117− ghcjs_dom_xml_http_request_send ::

118− JSRef XMLHttpRequest -> JSRef XhrPayload -> IO ()

119−

120−newtype XhrPayload = XhrPayload { unXhrPayload :: JSRef XhrPayload }

103+xmlHttpRequestOntimeout :: XMLHttpRequest -> EventM XMLHttpRequest ProgressEvent () -> IO (IO ())

104+xmlHttpRequestOntimeout = (`on` timeout)

121105

122−class IsXhrPayload a where

123− xmlHttpRequestSend :: IsXMLHttpRequest self => self -> a -> IO ()

106+xmlHttpRequestOnreadystatechange :: XMLHttpRequest -> EventM XMLHttpRequest Event () -> IO (IO ())

107+xmlHttpRequestOnreadystatechange = (`on` readyStateChange)

124108

125−instance IsXhrPayload () where

126− xmlHttpRequestSend xhr _ = xmlHttpRequestSendPayload xhr $ XhrPayload jsNull

109+xmlHttpRequestSetTimeout :: XMLHttpRequest -> Word -> IO ()

110+xmlHttpRequestSetTimeout = setTimeout

127111

128−instance IsXhrPayload String where

129− xmlHttpRequestSend xhr = xmlHttpRequestSendPayload xhr . XhrPayload . castRef . toJSString

130−

131−foreign import javascript unsafe "$r = new FormData(); $r['append']($1, $2)" fileToFormData :: JSString -> JSRef File -> IO (JSRef XhrPayload)

132−

133−instance IsXhrPayload File where

134− xmlHttpRequestSend xhr = xmlHttpRequestSendPayload xhr . XhrPayload <=< fileToFormData (toJSString "file") . unFile

135−

136−xmlHttpRequestSendPayload :: IsXMLHttpRequest self => self -> XhrPayload -> IO ()

137−xmlHttpRequestSendPayload self (XhrPayload p) = ghcjs_dom_xml_http_request_send (unXMLHttpRequest (toXMLHttpRequest self)) p

138−

139−

140−foreign import javascript unsafe "$1[\"setRequestHeader\"]($2, $3)"

141− ghcjs_dom_xml_http_request_set_request_header ::

142− JSRef XMLHttpRequest -> JSString -> JSString -> IO ()

143−

144−xmlHttpRequestSetRequestHeader ::

145− (IsXMLHttpRequest self, ToJSString header, ToJSString value) =>

146− self -> header -> value -> IO ()

147−xmlHttpRequestSetRequestHeader self header value

148− = ghcjs_dom_xml_http_request_set_request_header

149− (unXMLHttpRequest (toXMLHttpRequest self))

150− (toJSString header)

151− (toJSString value)

152−

153−foreign import javascript unsafe "$1[\"abort\"]()"

154− ghcjs_dom_xml_http_request_abort :: JSRef XMLHttpRequest -> IO ()

155−

156−xmlHttpRequestAbort :: (IsXMLHttpRequest self) => self -> IO ()

157−xmlHttpRequestAbort self

158− = ghcjs_dom_xml_http_request_abort

159− (unXMLHttpRequest (toXMLHttpRequest self))

160−

161−foreign import javascript unsafe "$1[\"getAllResponseHeaders\"]()"

162− ghcjs_dom_xml_http_request_get_all_response_headers ::

163− JSRef XMLHttpRequest -> IO JSString

164−

165−xmlHttpRequestGetAllResponseHeaders ::

166− (IsXMLHttpRequest self, FromJSString result) =>

167− self -> IO result

168−xmlHttpRequestGetAllResponseHeaders self

169− = fromJSString <$>

170− (ghcjs_dom_xml_http_request_get_all_response_headers

171− (unXMLHttpRequest (toXMLHttpRequest self)))

172−

173−foreign import javascript unsafe "$1[\"getResponseHeader\"]($2)"

174− ghcjs_dom_xml_http_request_get_response_header ::

175− JSRef XMLHttpRequest -> JSString -> IO JSString

176−

177−xmlHttpRequestGetResponseHeader ::

178− (IsXMLHttpRequest self, ToJSString header, FromJSString result) =>

179− self -> header -> IO result

180−xmlHttpRequestGetResponseHeader self header

181− = fromJSString <$>

182− (ghcjs_dom_xml_http_request_get_response_header

183− (unXMLHttpRequest (toXMLHttpRequest self))

184− (toJSString header))

185−

186−foreign import javascript unsafe "$1[\"overrideMimeType\"]($2)"

187− ghcjs_dom_xml_http_request_override_mime_type ::

188− JSRef XMLHttpRequest -> JSString -> IO ()

189−

190−xmlHttpRequestOverrideMimeType ::

191− (IsXMLHttpRequest self, ToJSString override) =>

192− self -> override -> IO ()

193−xmlHttpRequestOverrideMimeType self override

194− = ghcjs_dom_xml_http_request_override_mime_type

195− (unXMLHttpRequest (toXMLHttpRequest self))

196− (toJSString override)

197−

198−foreign import javascript unsafe

199− "($1[\"dispatchEvent\"]($2) ? 1 : 0)"

200− ghcjs_dom_xml_http_request_dispatch_event ::

201− JSRef XMLHttpRequest -> JSRef Event -> IO Bool

202−

203−xmlHttpRequestDispatchEvent ::

204− (IsXMLHttpRequest self, IsEvent evt) =>

205− self -> Maybe evt -> IO Bool

206−xmlHttpRequestDispatchEvent self evt

207− = ghcjs_dom_xml_http_request_dispatch_event

208− (unXMLHttpRequest (toXMLHttpRequest self))

209− (maybe jsNull (unEvent . toEvent) evt)

210−

211−cUNSENT :: Integer

212−cUNSENT = 0

213−

214−cOPENED :: Integer

215−cOPENED = 1

216−

217−cHEADERS_RECEIVED :: Integer

218−cHEADERS_RECEIVED = 2

219−

220−cLOADING :: Integer

221−cLOADING = 3

222−

223−cDONE :: Integer

224−cDONE = 4

225−

226−xmlHttpRequestOnabort ::

227− (IsXMLHttpRequest self) => Signal self (EventM UIEvent self ())

228−xmlHttpRequestOnabort = (connect "abort")

229−

230−xmlHttpRequestOnerror ::

231− (IsXMLHttpRequest self) => Signal self (EventM UIEvent self ())

232−xmlHttpRequestOnerror = (connect "error")

233−

234−xmlHttpRequestOnload ::

235− (IsXMLHttpRequest self) => Signal self (EventM UIEvent self ())

236−xmlHttpRequestOnload = (connect "load")

237−

238−xmlHttpRequestOnloadend ::

239− (IsXMLHttpRequest self) => Signal self (EventM UIEvent self ())

240−xmlHttpRequestOnloadend = (connect "loadend")

241−

242−xmlHttpRequestOnloadstart ::

243− (IsXMLHttpRequest self) => Signal self (EventM UIEvent self ())

244−xmlHttpRequestOnloadstart = (connect "loadstart")

245−

246−xmlHttpRequestOnprogress ::

247− (IsXMLHttpRequest self) => Signal self (EventM UIEvent self ())

248−xmlHttpRequestOnprogress = (connect "progress")

249−

250−xmlHttpRequestOntimeout ::

251− (IsXMLHttpRequest self) => Signal self (EventM UIEvent self ())

252−xmlHttpRequestOntimeout = (connect "timeout")

253−

254−xmlHttpRequestOnreadystatechange ::

255− (IsXMLHttpRequest self) => Signal self (EventM UIEvent self ())

256−xmlHttpRequestOnreadystatechange = (connect "readystatechange")

257−

258−foreign import javascript unsafe "$1[\"timeout\"] = $2;"

259− ghcjs_dom_xml_http_request_set_timeout ::

260− JSRef XMLHttpRequest -> Word -> IO ()

261−

262−xmlHttpRequestSetTimeout ::

263− (IsXMLHttpRequest self) => self -> Word -> IO ()

264−xmlHttpRequestSetTimeout self val

265− = ghcjs_dom_xml_http_request_set_timeout

266− (unXMLHttpRequest (toXMLHttpRequest self))

267− val

268−

269−foreign import javascript unsafe "$1[\"timeout\"]"

270− ghcjs_dom_xml_http_request_get_timeout ::

271− JSRef XMLHttpRequest -> IO Word

272−

273−xmlHttpRequestGetTimeout ::

274− (IsXMLHttpRequest self) => self -> IO Word

275−xmlHttpRequestGetTimeout self

276− = ghcjs_dom_xml_http_request_get_timeout

277− (unXMLHttpRequest (toXMLHttpRequest self))

278−

279−foreign import javascript unsafe "$1[\"readyState\"]"

280− ghcjs_dom_xml_http_request_get_ready_state ::

281− JSRef XMLHttpRequest -> IO Word

282−

283−xmlHttpRequestGetReadyState ::

284− (IsXMLHttpRequest self) => self -> IO Word

285−xmlHttpRequestGetReadyState self

286− = ghcjs_dom_xml_http_request_get_ready_state

287− (unXMLHttpRequest (toXMLHttpRequest self))

288−

289−foreign import javascript unsafe "$1[\"withCredentials\"] = $2;"

290− ghcjs_dom_xml_http_request_set_with_credentials ::

291− JSRef XMLHttpRequest -> Bool -> IO ()

292−

293−xmlHttpRequestSetWithCredentials ::

294− (IsXMLHttpRequest self) => self -> Bool -> IO ()

295−xmlHttpRequestSetWithCredentials self val

296− = ghcjs_dom_xml_http_request_set_with_credentials

297− (unXMLHttpRequest (toXMLHttpRequest self))

298− val

299−

300−foreign import javascript unsafe

301− "($1[\"withCredentials\"] ? 1 : 0)"

302− ghcjs_dom_xml_http_request_get_with_credentials ::

303− JSRef XMLHttpRequest -> IO Bool

304−

305−xmlHttpRequestGetWithCredentials ::

306− (IsXMLHttpRequest self) => self -> IO Bool

307−xmlHttpRequestGetWithCredentials self

308− = ghcjs_dom_xml_http_request_get_with_credentials

309− (unXMLHttpRequest (toXMLHttpRequest self))

310−

311−foreign import javascript unsafe "$1[\"upload\"]"

312− ghcjs_dom_xml_http_request_get_upload ::

313− JSRef XMLHttpRequest -> IO (JSRef XMLHttpRequestUpload)

314−

315−xmlHttpRequestGetUpload ::

316− (IsXMLHttpRequest self) => self -> IO (Maybe XMLHttpRequestUpload)

317−xmlHttpRequestGetUpload self

318− = fmap XMLHttpRequestUpload . maybeJSNull <$>

319− (ghcjs_dom_xml_http_request_get_upload

320− (unXMLHttpRequest (toXMLHttpRequest self)))

321−

322−foreign import javascript unsafe "$1[\"responseText\"]"

323− ghcjs_dom_xml_http_request_get_response_text ::

324− JSRef XMLHttpRequest -> IO JSString

325−

326−xmlHttpRequestGetResponseText ::

327− (IsXMLHttpRequest self, FromJSString result) => self -> IO (Maybe result)

328−xmlHttpRequestGetResponseText self

329− = fmap fromJSString . maybeJSNull <$>

330− (ghcjs_dom_xml_http_request_get_response_text

331− (unXMLHttpRequest (toXMLHttpRequest self)))

332−

333−responseTextToText :: (Maybe JSString) -> Maybe Text

334−responseTextToText r = fmap (T.pack . fromJSString) r

335−

336−statusTextToText :: Text -> Text

337−statusTextToText = id

338−

339−foreign import javascript unsafe "$1[\"responseXML\"]"

340− ghcjs_dom_xml_http_request_get_response_xml ::

341− JSRef XMLHttpRequest -> IO (JSRef Document)

342−

343−xmlHttpRequestGetResponseXML ::

344− (IsXMLHttpRequest self) => self -> IO (Maybe Document)

345−xmlHttpRequestGetResponseXML self

346− = fmap Document . maybeJSNull <$>

347− (ghcjs_dom_xml_http_request_get_response_xml

348− (unXMLHttpRequest (toXMLHttpRequest self)))

349−

350−foreign import javascript unsafe "$1[\"responseType\"] = $2;"

351− ghcjs_dom_xml_http_request_set_response_type ::

352− JSRef XMLHttpRequest -> JSString -> IO ()

353−

354−xmlHttpRequestSetResponseType ::

355− (IsXMLHttpRequest self, ToJSString val) => self -> val -> IO ()

356−xmlHttpRequestSetResponseType self val

357− = ghcjs_dom_xml_http_request_set_response_type

358− (unXMLHttpRequest (toXMLHttpRequest self))

359− (toJSString val)

360−

361−toResponseType :: (ToJSString a) => a -> JSString

362−toResponseType = toJSString

363−

364−foreign import javascript unsafe "$1[\"responseType\"]"

365− ghcjs_dom_xml_http_request_get_response_type ::

366− JSRef XMLHttpRequest -> IO JSString

367−

368−xmlHttpRequestGetResponseType ::

369− (IsXMLHttpRequest self, FromJSString result) => self -> IO result

370−xmlHttpRequestGetResponseType self

371− = fromJSString <$>

372− (ghcjs_dom_xml_http_request_get_response_type

373− (unXMLHttpRequest (toXMLHttpRequest self)))

374−

375−foreign import javascript unsafe "$1[\"status\"]"

376− ghcjs_dom_xml_http_request_get_status ::

377− JSRef XMLHttpRequest -> IO Word

378−

379−xmlHttpRequestGetStatus ::

380− (IsXMLHttpRequest self) => self -> IO Word

381−xmlHttpRequestGetStatus self

382− = ghcjs_dom_xml_http_request_get_status

383− (unXMLHttpRequest (toXMLHttpRequest self))

384−

385−foreign import javascript unsafe "$1[\"statusText\"]"

386− ghcjs_dom_xml_http_request_get_status_text ::

387− JSRef XMLHttpRequest -> IO JSString

388−

389−xmlHttpRequestGetStatusText ::

390− (IsXMLHttpRequest self, FromJSString result) => self -> IO result

391−xmlHttpRequestGetStatusText self

392− = fromJSString <$>

393− (ghcjs_dom_xml_http_request_get_status_text

394− (unXMLHttpRequest (toXMLHttpRequest self)))

395−

396−foreign import javascript unsafe "$1[\"responseURL\"]"

397− ghcjs_dom_xml_http_request_get_response_url ::

398− JSRef XMLHttpRequest -> IO JSString

399−

400−xmlHttpRequestGetResponseURL ::

401− (IsXMLHttpRequest self, FromJSString result) => self -> IO result

402−xmlHttpRequestGetResponseURL self

403− = fromJSString <$>

404− (ghcjs_dom_xml_http_request_get_response_url

405− (unXMLHttpRequest (toXMLHttpRequest self)))

112+xmlHttpRequestGetTimeout :: XMLHttpRequest -> IO Word

113+xmlHttpRequestGetTimeout = getTimeout

114+

115+xmlHttpRequestGetReadyState :: XMLHttpRequest -> IO Word

116+xmlHttpRequestGetReadyState = getReadyState

117+

118+xmlHttpRequestSetWithCredentials :: XMLHttpRequest -> Bool -> IO ()

119+xmlHttpRequestSetWithCredentials = setWithCredentials

120+

121+xmlHttpRequestGetWithCredentials :: XMLHttpRequest -> IO Bool

122+xmlHttpRequestGetWithCredentials = getWithCredentials

123+

124+xmlHttpRequestGetUpload :: XMLHttpRequest -> IO (Maybe XMLHttpRequestUpload)

125+xmlHttpRequestGetUpload = getUpload

126+

127+xmlHttpRequestGetResponseText :: FromJSString result => XMLHttpRequest -> IO (Maybe result)

128+xmlHttpRequestGetResponseText = getResponseText

129+

130+xmlHttpRequestGetResponseXML :: XMLHttpRequest -> IO (Maybe Document)

131+xmlHttpRequestGetResponseXML = getResponseXML

132+

133+xmlHttpRequestSetResponseType :: XMLHttpRequest -> XMLHttpRequestResponseType -> IO ()

134+xmlHttpRequestSetResponseType = setResponseType

135+

136+toResponseType :: XhrResponseType -> XMLHttpRequestResponseType

137+toResponseType XhrResponseType_Default = XMLHttpRequestResponseType

138+toResponseType XhrResponseType_ArrayBuffer = XMLHttpRequestResponseTypeArraybuffer

139+toResponseType XhrResponseType_Blob = XMLHttpRequestResponseTypeBlob

140+toResponseType XhrResponseType_Document = XMLHttpRequestResponseTypeDocument

141+toResponseType XhrResponseType_JSON = XMLHttpRequestResponseTypeJson

142+toResponseType XhrResponseType_Text = XMLHttpRequestResponseTypeText

143+

144+xmlHttpRequestGetResponseType :: XMLHttpRequest -> IO XMLHttpRequestResponseType

145+xmlHttpRequestGetResponseType = getResponseType

146+

147+xmlHttpRequestGetStatus :: XMLHttpRequest -> IO Word

148+xmlHttpRequestGetStatus = getStatus

149+

150+xmlHttpRequestGetStatusText :: FromJSString result => XMLHttpRequest -> IO result

151+xmlHttpRequestGetStatusText = getStatusText

152+

153+xmlHttpRequestGetResponseURL :: FromJSString result => XMLHttpRequest -> IO result

154+xmlHttpRequestGetResponseURL = getResponseURL

155+

156+xmlHttpRequestGetResponse :: XMLHttpRequest -> IO (Maybe XhrResponseBody)

157+xmlHttpRequestGetResponse xhr = do

158+ mr <- getResponse xhr

159+ return $ fmap (\(GObject r) -> XhrResponseBody r) mr

406160

src/Foreign/JavaScript/TH.hs+37−26

@@ -10,14 +10,27 @@ import Language.Haskell.TH

1010

1111#ifdef __GHCJS__

1212import qualified GHCJS.Marshal as JS

13+import qualified GHCJS.Marshal.Pure as JS

1314import qualified GHCJS.Foreign as JS

15+import qualified GHCJS.Foreign.Callback as JS

1416import qualified GHCJS.Types as JS

17+import qualified GHCJS.Buffer as JS

1518import GHCJS.DOM

16−import GHCJS.DOM.Types

19+import GHCJS.DOM.Types hiding (fromJSString)

20+import qualified GHCJS.DOM.Types as JS

21+import qualified JavaScript.Array as JS

22+import qualified JavaScript.Cast as JS

23+import qualified JavaScript.Object as JS

24+import qualified JavaScript.Object.Internal (Object (..))

25+import qualified GHCJS.Foreign.Callback.Internal (Callback (..))

26+import qualified JavaScript.Array.Internal (SomeJSArray (..))

27+import qualified JavaScript.TypedArray.ArrayBuffer as JSArrayBuffer

28+

1729import Data.Word

1830import Foreign.Ptr

1931import Foreign.C.Types

2032import Data.Hashable

33+import Text.Encoding.Z

2134#else

2235import System.Glib.FFI

2336import Graphics.UI.Gtk.WebKit.WebView

@@ -27,7 +40,6 @@ import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSStringRef

2740import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSValueRef

2841import Graphics.UI.Gtk.WebKit.JavaScriptCore.WebFrame

2942import Graphics.UI.Gtk.WebKit.DOM.Node

30−import Graphics.UI.Gtk.WebKit.Types

3143#endif

3244

3345import Control.Monad

@@ -42,7 +54,6 @@ import Data.ByteString (ByteString)

4254import qualified Data.ByteString as BS

4355import Control.Concurrent

4456import Data.Coerce

45−import Text.Encoding.Z

4657import Data.Monoid

4758

4859class Monad m => HasWebView m where

@@ -77,7 +88,7 @@ withWebViewSingleton wv f = f $ WebViewSingleton wv

7788newtype WebViewSingleton x = WebViewSingleton { unWebViewSingleton :: WebView }

7889

7990#ifdef __GHCJS__

80−type JSFFI_Internal = JS.JSArray (JSRef JSCtx_IO) -> IO (JS.JSRef (JSRef JSCtx_IO))

91+type JSFFI_Internal = JS.MutableJSArray -> IO JS.JSVal

8192newtype JSFFI = JSFFI JSFFI_Internal

8293#else

8394newtype JSFFI = JSFFI String

@@ -131,48 +142,48 @@ class Monad m => MonadJS x m | m -> x where

131142data JSCtx_IO

132143

133144instance IsJSContext JSCtx_IO where

134− newtype JSRef JSCtx_IO = JSRef_IO { unJSRef_IO :: JS.JSRef (JSRef JSCtx_IO) }

145+ newtype JSRef JSCtx_IO = JSRef_IO { unJSRef_IO :: JS.JSVal }

135146

136147instance MonadJS JSCtx_IO IO where

137− runJS (JSFFI f) l = liftM JSRef_IO . f =<< JS.toArray (coerce l)

148+ runJS (JSFFI f) l = liftM JSRef_IO . f =<< JS.fromListIO (coerce l)

138149 forkJS = forkIO

139150 mkJSUndefined = return $ JSRef_IO JS.jsUndefined

140151 isJSNull (JSRef_IO r) = return $ JS.isNull r

141152 isJSUndefined (JSRef_IO r) = return $ JS.isUndefined r

142− fromJSBool (JSRef_IO r) = return $ JS.fromJSBool $ JS.castRef r

143− fromJSString (JSRef_IO r) = return $ JS.fromJSString $ JS.castRef r

144− fromJSArray (JSRef_IO r) = liftM coerce $ JS.fromArray $ JS.castRef r

145− fromJSUint8Array (JSRef_IO r) = JS.bufferByteString 0 0 $ JS.castRef r

153+ fromJSBool (JSRef_IO r) = return $ JS.fromJSBool r

154+ fromJSString (JSRef_IO r) = return $ JS.fromJSString $ JS.pFromJSVal r

155+ fromJSArray (JSRef_IO r) = liftM coerce $ JS.toListIO $ coerce r

156+ fromJSUint8Array (JSRef_IO r) = liftM (JS.toByteString 0 Nothing . JS.createFromArrayBuffer) $ JSArrayBuffer.unsafeFreeze $ JS.pFromJSVal r --TODO: Assert that this is immutable

146157 fromJSNumber (JSRef_IO r) = do

147− Just n <- JS.fromJSRef $ JS.castRef r

158+ Just n <- JS.fromJSVal r

148159 return n

149− withJSBool b f = f $ JSRef_IO $ JS.castRef $ JS.toJSBool b

150− withJSString s f = f $ JSRef_IO $ JS.castRef $ JS.toJSString s

160+ withJSBool b f = f $ JSRef_IO $ JS.toJSBool b

161+ withJSString s f = f $ JSRef_IO $ JS.pToJSVal $ JS.toJSString s

151162 withJSNumber n f = do

152− r <- JS.toJSRef n

153− f $ JSRef_IO $ JS.castRef r

163+ r <- JS.toJSVal n

164+ f $ JSRef_IO r

154165 withJSArray l f = do

155− r <- JS.toArray $ coerce l

156− f $ JSRef_IO $ JS.castRef r

166+ r <- JS.fromListIO $ coerce l

167+ f $ JSRef_IO $ coerce r

157168 withJSUint8Array payload f = BS.useAsCString payload $ \cStr -> do

158169 ba <- extractByteArray cStr $ BS.length payload

159170 f $ JSUint8Array $ JSRef_IO ba

160171 mkJSFun f = do

161− cb <- JS.syncCallback1 JS.AlwaysRetain True $ \args -> do

162− l <- JS.fromArray args

172+ cb <- JS.syncCallback1' $ \args -> do

173+ l <- JS.toListIO $ coerce args

163174 JSRef_IO result <- f $ coerce l

164− return $ JS.castRef result

165− liftM (JSFun . JSRef_IO) $ funWithArguments cb

166− freeJSFun (JSFun (JSRef_IO r)) = JS.release $ JS.castRef r

167− setJSProp s (JSRef_IO v) (JSRef_IO o) = JS.setProp s v o

175+ return result

176+ liftM (JSFun . JSRef_IO) $ funWithArguments $ coerce cb

177+ freeJSFun (JSFun (JSRef_IO r)) = JS.releaseCallback $ coerce r

178+ setJSProp s (JSRef_IO v) (JSRef_IO o) = JS.setProp (JS.toJSString s) v $ coerce o

168179 getJSProp s (JSRef_IO o) = do

169− r <- JS.getProp s o

180+ r <- JS.getProp (JS.toJSString s) $ coerce o

170181 return $ JSRef_IO r

171− withJSNode n f = f $ JSRef_IO $ JS.castRef $ unNode n

182+ withJSNode n f = f $ JSRef_IO $ unNode n

172183

173184foreign import javascript unsafe "new Uint8Array($1_1.buf, $1_2, $2)" extractByteArray :: Ptr CChar -> Int -> IO (JS.JSRef (JSRef JSCtx_IO))

174185

175−foreign import javascript unsafe "function(){ return $1(arguments); }" funWithArguments :: JS.JSFun (JS.JSArray (JS.JSRef b) -> IO a) -> IO (JS.JSRef (JSRef JSCtx_IO))

186+foreign import javascript unsafe "function(){ return $1(arguments); }" funWithArguments :: JS.Callback (JS.MutableJSArray -> IO a) -> IO JS.JSVal

176187

177188#else

178189

src/Reflex/Dom/Class.hs+4−5

@@ -19,8 +19,7 @@ import Control.Monad.State hiding (mapM, mapM_, forM, forM_, sequence)

1919import qualified Control.Monad.State.Strict as Strict hiding (mapM, mapM_, forM, forM_, sequence)

2020import Data.Dependent.Sum (DSum (..))

2121import GHCJS.DOM.Types hiding (Event)

22−import GHCJS.DOM (WebView)

23−import Control.Monad.Exception

22+--import GHCJS.DOM (WebView)

2423

2524-- | Alias for Data.Map.singleton

2625(=:) :: k -> a -> Map k a

@@ -80,14 +79,14 @@ instance MonadIORestore m => MonadIORestore (ReaderT r m) where

8079

8180class (MonadRef h, Ref h ~ Ref m, MonadRef m) => HasPostGui t h m | m -> t h where

8281 askPostGui :: m (h () -> IO ())

83− askRunWithActions :: m ([DSum (EventTrigger t)] -> h ())

82+ askRunWithActions :: m ([DSum (EventTrigger t) Identity] -> h ())

8483 scheduleFollowup :: Ref m (Maybe (EventTrigger t a)) -> a -> m ()

8584

8685runFrameWithTriggerRef :: (HasPostGui t h m, MonadRef m, MonadIO m) => Ref m (Maybe (EventTrigger t a)) -> a -> m ()

8786runFrameWithTriggerRef r a = do

8887 postGui <- askPostGui

8988 runWithActions <- askRunWithActions

90− liftIO . postGui $ mapM_ (\t -> runWithActions [t :=> a]) =<< readRef r

89+ liftIO . postGui $ mapM_ (\t -> runWithActions [t :=> Identity a]) =<< readRef r

9190

9291instance HasPostGui t h m => HasPostGui t h (ReaderT r m) where

9392 askPostGui = lift askPostGui

@@ -143,7 +142,7 @@ performEventAsync e = do

143142 addVoidAction $ ffor e $ \o -> do

144143 postGui <- askPostGui

145144 runWithActions <- askRunWithActions

146− o $ \a -> postGui $ mapM_ (\t -> runWithActions [t :=> a]) =<< readRef reResultTrigger

145+ o $ \a -> postGui $ mapM_ (\t -> runWithActions [t :=> Identity a]) =<< readRef reResultTrigger

147146 return eResult

148147

149148getPostBuild :: MonadWidget t m => m (Event t ())

src/Reflex/Dom/Internal.hs+18−15

@@ -5,12 +5,11 @@ import Prelude hiding (mapM, mapM_, concat, sequence, sequence_)

66import Reflex.Dom.Internal.Foreign

77import Reflex.Dom.Class

8−import Foreign.JavaScript.TH

109import GHCJS.DOM hiding (runWebGUI)

1110import GHCJS.DOM.Types hiding (Widget, unWidget, Event)

1211import GHCJS.DOM.Node

13−import GHCJS.DOM.HTMLElement

12+import GHCJS.DOM.Element

1413import GHCJS.DOM.Document

1514import Reflex.Class

1615import Reflex.Host.Class

@@ -38,9 +37,9 @@ newtype EventTriggerRef t m a = EventTriggerRef { unEventTriggerRef :: Ref m (Ma

3837data GuiEnv t h x

3938 = GuiEnv { _guiEnvDocument :: !HTMLDocument

4039 , _guiEnvPostGui :: !(h () -> IO ())

41− , _guiEnvRunWithActions :: !([DSum (EventTrigger t)] -> h ())

40+ , _guiEnvRunWithActions :: !([DSum (EventTrigger t) Identity] -> h ())

4241 , _guiEnvWebView :: !(WebViewSingleton x)

43− , _guiEnvFollowupEvents :: Ref h [DSum (EventTriggerRef t h)]

42+ , _guiEnvFollowupEvents :: Ref h [DSum (EventTriggerRef t h) Identity]

4443 }

4544

4645--TODO: Poorly named

@@ -110,7 +109,7 @@ instance (MonadRef h, Ref h ~ Ref m, MonadRef m) => HasPostGui t h (Gui t h x m)

110109 askRunWithActions = Gui $ view guiEnvRunWithActions

111110 scheduleFollowup r a = Gui $ do

112111 followupEventsRef <- view guiEnvFollowupEvents

113− modifyRef' followupEventsRef $ ((EventTriggerRef r :=> a) :)

112+ modifyRef' followupEventsRef $ ((EventTriggerRef r :=> Identity a) :)

114113

115114instance HasPostGui t h m => HasPostGui t h (Widget t m) where

116115 askPostGui = lift askPostGui

@@ -174,6 +173,10 @@ instance ( MonadRef m, Ref m ~ Ref IO, MonadRef h, Ref h ~ Ref IO --TODO: Should

174173-- runWidget :: (Monad m, IsNode n, Reflex t) => n -> Widget t m a -> m (a, Event t (m ()))

175174 getRunWidget = return runWidget

176175

176+getQuitWidget :: MonadWidget t m => m (WidgetHost m ())

177+getQuitWidget = return $ do WebViewSingleton wv <- askWebView

178+ liftIO $ quitWebView wv

179+

177180runWidget :: (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)) ()))

178181runWidget rootElement w = do

179182 (result, WidgetState postBuild voidActions) <- runStateT (runReaderT (unWidget w) (WidgetEnv $ toNode rootElement)) (WidgetState (return ()) [])

@@ -191,24 +194,24 @@ holdOnStartup a0 ma = do

191194mainWidget :: (forall x. Widget Spider (Gui Spider (WithWebView x SpiderHost) x (HostFrame Spider)) ()) -> IO ()

192195mainWidget w = runWebGUI $ \webView -> withWebViewSingleton webView $ \webViewSing -> do

193196 Just doc <- liftM (fmap castToHTMLDocument) $ webViewGetDomDocument webView

194− Just body <- documentGetBody doc

197+ Just body <- getBody doc

195198 attachWidget body webViewSing w

196199

197200--TODO: The x's should be unified here

198201mainWidgetWithHead :: (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 ()

199202mainWidgetWithHead h b = runWebGUI $ \webView -> withWebViewSingleton webView $ \webViewSing -> do

200203 Just doc <- liftM (fmap castToHTMLDocument) $ webViewGetDomDocument webView

201− Just headElement <- liftM (fmap castToHTMLElement) $ documentGetHead doc

204+ Just headElement <- liftM (fmap castToHTMLElement) $ getHead doc

202205 attachWidget headElement webViewSing h

203− Just body <- documentGetBody doc

206+ Just body <- getBody doc

204207 attachWidget body webViewSing b

205208

206209mainWidgetWithCss :: ByteString -> (forall x. Widget Spider (Gui Spider (WithWebView x SpiderHost) x (HostFrame Spider)) ()) -> IO ()

207210mainWidgetWithCss css w = runWebGUI $ \webView -> withWebViewSingleton webView $ \webViewSing -> do

208211 Just doc <- liftM (fmap castToHTMLDocument) $ webViewGetDomDocument webView

209− Just headElement <- liftM (fmap castToHTMLElement) $ documentGetHead doc

210− htmlElementSetInnerHTML headElement $ "<style>" <> T.unpack (decodeUtf8 css) <> "</style>" --TODO: Fix this

211− Just body <- documentGetBody doc

212+ Just headElement <- liftM (fmap castToHTMLElement) $ getHead doc

213+ setInnerHTML headElement . Just $ "<style>" <> T.unpack (decodeUtf8 css) <> "</style>" --TODO: Fix this

214+ Just body <- getBody doc

212215 attachWidget body webViewSing w

213216

214217instance 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

252255

253256attachWidget :: forall e x a. (IsHTMLElement e) => e -> WebViewSingleton x -> Widget Spider (Gui Spider (WithWebView x SpiderHost) x (HostFrame Spider)) a -> IO a

254257attachWidget 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

255− Just doc <- liftM (fmap castToHTMLDocument) $ liftIO $ nodeGetOwnerDocument rootElement

258+ Just doc <- liftM (fmap castToHTMLDocument) $ getOwnerDocument rootElement

256259 frames <- liftIO newChan

257260 followupEvents <- liftIO $ newIORef []

258261 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

273276 Just t -> return $ Just (t :=> a)

274277 let fe'' = catMaybes fe'

275278 when (not $ null fe'') $ runWithActions fe''

276− Just df <- liftIO $ documentCreateDocumentFragment doc

279+ Just df <- liftIO $ createDocumentFragment doc

277280 (result, voidAction) <- runHostFrame $ flip runGui guiEnv $ do

278281 (r, postBuild, va) <- runWidget df w

279282 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

280283 return (r, va)

281− liftIO $ htmlElementSetInnerHTML rootElement ""

282− _ <- liftIO $ nodeAppendChild rootElement $ Just df

284+ setInnerHTML rootElement $ Just ""

285+ _ <- appendChild rootElement $ Just df

283286 voidActionHandle <- subscribeEvent voidAction --TODO: Should be unnecessary

284287 --postGUISync seems to leak memory on GHC (unknown on GHCJS)

285288 doFollowup -- This must go after voidActionHandle is subscribed; otherwise, a loop results

src/Reflex/Dom/Time.hs+1−1

@@ -166,7 +166,7 @@ inhomogeneousPoisson

166166inhomogeneousPoisson rnd rate maxRate t0 =

167167 inhomogeneousPoissonFrom rnd rate maxRate t0 =<< getPostBuild

168168

169−-- | Block occurrences of an Event until th given number of seconds elapses without

169+-- | Block occurrences of an Event until the given number of seconds elapses without

170170-- the Event firing, at which point the last occurrence of the Event will fire.

171171debounce :: MonadWidget t m => NominalDiffTime -> Event t a -> m (Event t a)

172172debounce dt e = do

src/Reflex/Dom/WebSocket.hs+2−2

@@ -44,10 +44,10 @@ webSocket url config = do

4444 let onMessage :: ByteString -> IO ()

4545 onMessage m = postGui $ do

4646 mt <- readRef eRecvTriggerRef

47− forM_ mt $ \t -> runWithActions [t :=> m]

47+ forM_ mt $ \t -> runWithActions [t :=> Identity m]

4848 onOpen = postGui $ do

4949 mt <- readRef eOpenTriggerRef

50− forM_ mt $ \t -> runWithActions [t :=> ()]

50+ forM_ mt $ \t -> runWithActions [t :=> Identity ()]

5151 start = do

5252 ws <- liftIO $ newWebSocket wv url onMessage onOpen $ do

5353 void $ forkIO $ do --TODO: Is the fork necessary, or do event handlers run in their own threads automatically?

src/Reflex/Dom/Widget/Basic.hs+158−148

@@ -21,12 +21,12 @@ import Control.Monad.Reader hiding (mapM, mapM_, forM, forM_, sequence, sequence

2121import Control.Monad.State hiding (state, mapM, mapM_, forM, forM_, sequence, sequence_)

2222import GHCJS.DOM.Node

2323import GHCJS.DOM.UIEvent

24−import GHCJS.DOM.EventM (event, EventM, stopPropagation)

24+import GHCJS.DOM.EventM (on, event, EventM, stopPropagation)

2525import GHCJS.DOM.Document

26−import GHCJS.DOM.Element

27−import GHCJS.DOM.HTMLElement

28−import GHCJS.DOM.Types hiding (Widget (..), unWidget, Event)

29−import GHCJS.DOM.NamedNodeMap

26+import GHCJS.DOM.Element as E

27+import GHCJS.DOM.Types hiding (Event)

28+import qualified GHCJS.DOM.Types as DOM (Event)

29+import GHCJS.DOM.NamedNodeMap as NNM

3030import Control.Lens hiding (element, children)

3131import Data.These

3232import Data.Align

@@ -60,27 +60,27 @@ class Attributes m a where

6060 addAttributes :: IsElement e => a -> e -> m ()

6161

6262instance MonadIO m => Attributes m AttributeMap where

63− addAttributes curAttrs e = liftIO $ imapM_ (elementSetAttribute e) curAttrs

63+ addAttributes curAttrs e = imapM_ (setAttribute e) curAttrs

6464

6565instance MonadWidget t m => Attributes m (Dynamic t AttributeMap) where

6666 addAttributes attrs e = do

6767 schedulePostBuild $ do

6868 curAttrs <- sample $ current attrs

69− liftIO $ imapM_ (elementSetAttribute e) curAttrs

69+ imapM_ (setAttribute e) curAttrs

7070 addVoidAction $ flip fmap (updated attrs) $ \newAttrs -> liftIO $ do

71− oldAttrs <- maybe (return Set.empty) namedNodeMapGetNames =<< elementGetAttributes e

72− forM_ (Set.toList $ oldAttrs `Set.difference` Map.keysSet newAttrs) $ elementRemoveAttribute e

73− imapM_ (elementSetAttribute e) newAttrs --TODO: avoid re-setting unchanged attributes; possibly do the compare using Align in haskell

71+ oldAttrs <- maybe (return Set.empty) namedNodeMapGetNames =<< getAttributes e

72+ forM_ (Set.toList $ oldAttrs `Set.difference` Map.keysSet newAttrs) $ removeAttribute e

73+ imapM_ (setAttribute e) newAttrs --TODO: avoid re-setting unchanged attributes; possibly do the compare using Align in haskell

7474

7575buildEmptyElementNS :: (MonadWidget t m, Attributes m attrs) => Maybe String -> String -> attrs -> m Element

7676buildEmptyElementNS mns elementTag attrs = do

7777 doc <- askDocument

7878 p <- askParent

7979 Just e <- liftIO $ case mns of

80− Nothing -> documentCreateElement doc elementTag

81− Just ns -> documentCreateElementNS doc ns elementTag

80+ Nothing -> createElement doc (Just elementTag)

81+ Just ns -> createElementNS doc (Just ns) (Just elementTag)

8282 addAttributes attrs e

83− _ <- liftIO $ nodeAppendChild p $ Just e

83+ _ <- appendChild p $ Just e

8484 return $ castToElement e

8585

8686buildEmptyElement :: (MonadWidget t m, Attributes m attrs) => String -> attrs -> m Element

@@ -96,13 +96,13 @@ buildElementNS mns elementTag attrs child = do

9696buildElement :: (MonadWidget t m, Attributes m attrs) => String -> attrs -> m a -> m (Element, a)

9797buildElement = buildElementNS Nothing

9898

99−namedNodeMapGetNames :: IsNamedNodeMap self => self -> IO (Set String)

99+namedNodeMapGetNames :: NamedNodeMap -> IO (Set String)

100100namedNodeMapGetNames self = do

101− l <- namedNodeMapGetLength self

101+ l <- NNM.getLength self

102102 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

103− liftM Set.fromList $ forM locations $ \i -> do

104− Just n <- namedNodeMapItem self i

105− nodeGetNodeName n

103+ liftM (Set.fromList . catMaybes) $ forM locations $ \i -> do

104+ Just n <- NNM.item self i

105+ getNodeName n

106106

107107text :: MonadWidget t m => String -> m ()

108108text = void . text'

@@ -112,8 +112,8 @@ text' :: MonadWidget t m => String -> m Text

112112text' s = do

113113 doc <- askDocument

114114 p <- askParent

115− Just n <- liftIO $ documentCreateTextNode doc s

116− _ <- liftIO $ nodeAppendChild p $ Just n

115+ Just n <- createTextNode doc s

116+ _ <- appendChild p $ Just n

117117 return n

118118

119119dynText :: MonadWidget t m => Dynamic t String -> m ()

@@ -121,8 +121,8 @@ dynText s = do

121121 n <- text' ""

122122 schedulePostBuild $ do

123123 curS <- sample $ current s

124− liftIO $ nodeSetNodeValue n curS

125− addVoidAction $ fmap (liftIO . nodeSetNodeValue n) $ updated s

124+ setNodeValue n $ Just curS

125+ addVoidAction $ fmap (setNodeValue n . Just) $ updated s

126126

127127display :: (MonadWidget t m, Show a) => Dynamic t a -> m ()

128128display a = dynText =<< mapDyn show a

@@ -159,12 +159,12 @@ widgetHoldInternal child0 newChild = do

159159 doc <- askDocument

160160 runWidget <- getRunWidget

161161 let build c = do

162− Just df <- liftIO $ documentCreateDocumentFragment doc

162+ Just df <- createDocumentFragment doc

163163 (result, postBuild, voidActions) <- runWidget df c

164164 scheduleFollowup newChildBuiltTriggerRef (result, voidActions)

165165 postBuild

166− mp' <- liftIO $ nodeGetParentNode endPlaceholder

167− forM_ mp' $ \p' -> liftIO $ nodeInsertBefore p' (Just df) (Just endPlaceholder)

166+ mp' <- getParentNode endPlaceholder

167+ forM_ mp' $ \p' -> insertBefore p' (Just df) (Just endPlaceholder)

168168 return ()

169169 addVoidAction $ ffor newChild $ \c -> do

170170 liftIO $ deleteBetweenExclusive startPlaceholder endPlaceholder

@@ -209,7 +209,7 @@ listWithKeyShallowDiff initialVals valsChanged mkChild = do

209209 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

210210 Just _ -> Nothing -- We don't want to let spurious re-creations of items through

211211 listHoldWithKey initialVals (attachWith (flip (Map.differenceWith relevantDiff)) (current sentVals) valsChanged) $ \k v ->

212− mkChild k v $ select childValChangedSelector $ Const2 k

212+ mkChild k v $ Reflex.select childValChangedSelector $ Const2 k

213213

214214-- | 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.

215215listHoldWithKey :: (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

224224 result <- mkChild k v

225225 childEnd <- text' ""

226226 return (result, (childStart, childEnd))

227− Just dfOrig <- liftIO $ documentCreateDocumentFragment doc

227+ Just dfOrig <- createDocumentFragment doc

228228 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

229229 stateRef <- liftIO $ newIORef initialState

230230 children <- holdDyn initialState newChildren

231231 tellWidgetOutput =<< mapDyn (fmap snd) children

232− mpOrig <- liftIO $ nodeGetParentNode endPlaceholder

233− forM_ mpOrig $ \pOrig -> liftIO $ nodeInsertBefore pOrig (Just dfOrig) (Just endPlaceholder)

232+ mpOrig <- getParentNode endPlaceholder

233+ forM_ mpOrig $ \pOrig -> insertBefore pOrig (Just dfOrig) (Just endPlaceholder)

234234 addVoidAction $ flip fmap valsChanged $ \newVals -> do

235235 curState <- liftIO $ readIORef stateRef

236236 --TODO: Should we remove the parent from the DOM first to avoid reflows?

@@ -240,24 +240,24 @@ listHoldWithKey initialVals valsChanged mkChild = do

240240 return Nothing

241241 These ((_, (start, end)), _) (Just v) -> do -- Replacing existing child

242242 liftIO $ deleteBetweenExclusive start end

243− Just df <- liftIO $ documentCreateDocumentFragment doc

243+ Just df <- createDocumentFragment doc

244244 (childResult, childPostBuild, childVoidAction) <- lift $ buildChild df k v

245245 let s = (childResult, childVoidAction)

246246 modify (>>childPostBuild)

247− mp <- liftIO $ nodeGetParentNode end

248− forM_ mp $ \p -> liftIO $ nodeInsertBefore p (Just df) (Just end)

247+ mp <- getParentNode end

248+ forM_ mp $ \p -> insertBefore p (Just df) (Just end)

249249 return $ Just s

250250 That Nothing -> return Nothing -- Deleting non-existent child

251251 That (Just v) -> do -- Creating new child

252− Just df <- liftIO $ documentCreateDocumentFragment doc

252+ Just df <- createDocumentFragment doc

253253 (childResult, childPostBuild, childVoidAction) <- lift $ buildChild df k v

254254 let s = (childResult, childVoidAction)

255255 modify (>>childPostBuild)

256256 let placeholder = case Map.lookupGT k curState of

257257 Nothing -> endPlaceholder

258258 Just (_, ((_, (start, _)), _)) -> start

259− mp <- liftIO $ nodeGetParentNode placeholder

260− forM_ mp $ \p -> liftIO $ nodeInsertBefore p (Just df) (Just placeholder)

259+ mp <- getParentNode placeholder

260+ forM_ mp $ \p -> insertBefore p (Just df) (Just placeholder)

261261 return $ Just s

262262 This state -> do -- No change

263263 return $ Just state

@@ -303,47 +303,56 @@ selectViewListWithKey_ selection vals mkChild = liftM (fmap fst) $ selectViewLis

303303-- | s and e must both be children of the same node and s must precede e

304304deleteBetweenExclusive :: (IsNode start, IsNode end) => start -> end -> IO ()

305305deleteBetweenExclusive s e = do

306− 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

306+ 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

307307 case mCurrentParent of

308308 Nothing -> return () --TODO: Is this the right behavior?

309309 Just currentParent -> do

310310 let go = do

311− Just x <- nodeGetPreviousSibling e -- This can't be Nothing because we should hit 's' first

311+ Just x <- getPreviousSibling e -- This can't be Nothing because we should hit 's' first

312312 when (toNode s /= toNode x) $ do

313− _ <- nodeRemoveChild currentParent $ Just x

313+ _ <- removeChild currentParent $ Just x

314314 go

315315 go

316316

317317-- | s and e must both be children of the same node and s must precede e

318318deleteBetweenInclusive :: (IsNode start, IsNode end) => start -> end -> IO ()

319319deleteBetweenInclusive s e = do

320− 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

320+ 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

321321 case mCurrentParent of

322322 Nothing -> return () --TODO: Is this the right behavior?

323323 Just currentParent -> do

324324 let go = do

325− Just x <- nodeGetPreviousSibling e -- This can't be Nothing because we should hit 's' first

326− _ <- nodeRemoveChild currentParent $ Just x

325+ Just x <- getPreviousSibling e -- This can't be Nothing because we should hit 's' first

326+ _ <- removeChild currentParent $ Just x

327327 when (toNode s /= toNode x) go

328328 go

329− _ <- nodeRemoveChild currentParent $ Just e

329+ _ <- removeChild currentParent $ Just e

330330 return ()

331331

332+nodeClear :: IsNode self => self -> IO ()

333+nodeClear n = do

334+ mfc <- getFirstChild n

335+ case mfc of

336+ Nothing -> return ()

337+ Just fc -> do

338+ _ <- removeChild n $ Just fc

339+ nodeClear n

340+

332341--------------------------------------------------------------------------------

333342-- Adapters

334343--------------------------------------------------------------------------------

335344

336−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)

345+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)

337346wrapDomEvent element elementOnevent getValue = wrapDomEventMaybe element elementOnevent $ liftM Just getValue

338347

339−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)

348+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)

340349wrapDomEventMaybe element elementOnevent getValue = do

341350 postGui <- askPostGui

342351 runWithActions <- askRunWithActions

343352 e <- newEventWithTrigger $ \et -> do

344353 unsubscribe <- {-# SCC "a" #-} liftIO $ {-# SCC "b" #-} elementOnevent element $ {-# SCC "c" #-} do

345354 mv <- {-# SCC "d" #-} getValue

346− forM_ mv $ \v -> liftIO $ postGui $ runWithActions [et :=> v]

355+ forM_ mv $ \v -> liftIO $ postGui $ runWithActions [et :=> Identity v]

347356 return $ liftIO $ do

348357 {-# SCC "e" #-} unsubscribe

349358 return $! {-# SCC "f" #-} e

@@ -377,11 +386,11 @@ data EventTag

377386 | MouseoutTag

378387 | MouseoverTag

379388 | MouseupTag

380−-- | 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

389+ | MousewheelTag

381390 | ScrollTag

382391 | SelectTag

383392 | SubmitTag

384−-- | WheelTag -- See MousewheelTag

393+ | WheelTag

385394 | BeforecutTag

386395 | CutTag

387396 | BeforecopyTag

@@ -425,11 +434,11 @@ data EventName :: EventTag -> * where

425434 Mouseout :: EventName 'MouseoutTag

426435 Mouseover :: EventName 'MouseoverTag

427436 Mouseup :: EventName 'MouseupTag

428− --Mousewheel :: EventName 'MousewheelTag

437+ Mousewheel :: EventName 'MousewheelTag

429438 Scroll :: EventName 'ScrollTag

430439 Select :: EventName 'SelectTag

431440 Submit :: EventName 'SubmitTag

432− --Wheel :: EventName 'WheelTag

441+ Wheel :: EventName 'WheelTag

433442 Beforecut :: EventName 'BeforecutTag

434443 Cut :: EventName 'CutTag

435444 Beforecopy :: EventName 'BeforecopyTag

@@ -446,8 +455,8 @@ data EventName :: EventTag -> * where

446455

447456type family EventType en where

448457 EventType 'AbortTag = UIEvent

449− EventType 'BlurTag = UIEvent

450− EventType 'ChangeTag = UIEvent

458+ EventType 'BlurTag = FocusEvent

459+ EventType 'ChangeTag = DOM.Event

451460 EventType 'ClickTag = MouseEvent

452461 EventType 'ContextmenuTag = MouseEvent

453462 EventType 'DblclickTag = MouseEvent

@@ -459,87 +468,87 @@ type family EventType en where

459468 EventType 'DragstartTag = MouseEvent

460469 EventType 'DropTag = MouseEvent

461470 EventType 'ErrorTag = UIEvent

462− EventType 'FocusTag = UIEvent

463− EventType 'InputTag = UIEvent

464− EventType 'InvalidTag = UIEvent

465− EventType 'KeydownTag = UIEvent

466− EventType 'KeypressTag = UIEvent

467− EventType 'KeyupTag = UIEvent

471+ EventType 'FocusTag = FocusEvent

472+ EventType 'InputTag = DOM.Event

473+ EventType 'InvalidTag = DOM.Event

474+ EventType 'KeydownTag = KeyboardEvent

475+ EventType 'KeypressTag = KeyboardEvent

476+ EventType 'KeyupTag = KeyboardEvent

468477 EventType 'LoadTag = UIEvent

469478 EventType 'MousedownTag = MouseEvent

470− EventType 'MouseenterTag = UIEvent

471− EventType 'MouseleaveTag = UIEvent

479+ EventType 'MouseenterTag = MouseEvent

480+ EventType 'MouseleaveTag = MouseEvent

472481 EventType 'MousemoveTag = MouseEvent

473482 EventType 'MouseoutTag = MouseEvent

474483 EventType 'MouseoverTag = MouseEvent

475484 EventType 'MouseupTag = MouseEvent

476− --EventType 'MousewheelTag = MouseEvent

485+ EventType 'MousewheelTag = MouseEvent

477486 EventType 'ScrollTag = UIEvent

478487 EventType 'SelectTag = UIEvent

479− EventType 'SubmitTag = UIEvent

480− --EventType 'WheelTag = UIEvent

481− EventType 'BeforecutTag = UIEvent

482− EventType 'CutTag = UIEvent

483− EventType 'BeforecopyTag = UIEvent

484− EventType 'CopyTag = UIEvent

485− EventType 'BeforepasteTag = UIEvent

486− EventType 'PasteTag = UIEvent

487− EventType 'ResetTag = UIEvent

488− EventType 'SearchTag = UIEvent

489− EventType 'SelectstartTag = UIEvent

490− EventType 'TouchstartTag = UIEvent

491− EventType 'TouchmoveTag = UIEvent

492− EventType 'TouchendTag = UIEvent

493− EventType 'TouchcancelTag = UIEvent

494−

495−onEventName :: IsElement e => EventName en -> e -> EventM (EventType en) e () -> IO (IO ())

496−onEventName en = case en of

497− Abort -> elementOnabort

498− Blur -> elementOnblur

499− Change -> elementOnchange

500− Click -> elementOnclick

501− Contextmenu -> elementOncontextmenu

502− Dblclick -> elementOndblclick

503− Drag -> elementOndrag

504− Dragend -> elementOndragend

505− Dragenter -> elementOndragenter

506− Dragleave -> elementOndragleave

507− Dragover -> elementOndragover

508− Dragstart -> elementOndragstart

509− Drop -> elementOndrop

510− Error -> elementOnerror

511− Focus -> elementOnfocus

512− Input -> elementOninput

513− Invalid -> elementOninvalid

514− Keydown -> elementOnkeydown

515− Keypress -> elementOnkeypress

516− Keyup -> elementOnkeyup

517− Load -> elementOnload

518− Mousedown -> elementOnmousedown

519− Mouseenter -> elementOnmouseenter

520− Mouseleave -> elementOnmouseleave

521− Mousemove -> elementOnmousemove

522− Mouseout -> elementOnmouseout

523− Mouseover -> elementOnmouseover

524− Mouseup -> elementOnmouseup

525− --Mousewheel -> elementOnmousewheel

526− Scroll -> elementOnscroll

527− Select -> elementOnselect

528− Submit -> elementOnsubmit

529− --Wheel -> elementOnwheel

530− Beforecut -> elementOnbeforecut

531− Cut -> elementOncut

532− Beforecopy -> elementOnbeforecopy

533− Copy -> elementOncopy

534− Beforepaste -> elementOnbeforepaste

535− Paste -> elementOnpaste

536− Reset -> elementOnreset

537− Search -> elementOnsearch

538− Selectstart -> elementOnselectstart

539− Touchstart -> elementOntouchstart

540− Touchmove -> elementOntouchmove

541− Touchend -> elementOntouchend

542− Touchcancel -> elementOntouchcancel

488+ EventType 'SubmitTag = DOM.Event

489+ EventType 'WheelTag = WheelEvent

490+ EventType 'BeforecutTag = DOM.Event

491+ EventType 'CutTag = DOM.Event

492+ EventType 'BeforecopyTag = DOM.Event

493+ EventType 'CopyTag = DOM.Event

494+ EventType 'BeforepasteTag = DOM.Event

495+ EventType 'PasteTag = DOM.Event

496+ EventType 'ResetTag = DOM.Event

497+ EventType 'SearchTag = DOM.Event

498+ EventType 'SelectstartTag = DOM.Event

499+ EventType 'TouchstartTag = TouchEvent

500+ EventType 'TouchmoveTag = TouchEvent

501+ EventType 'TouchendTag = TouchEvent

502+ EventType 'TouchcancelTag = TouchEvent

503+

504+onEventName :: IsElement e => EventName en -> e -> EventM e (EventType en) () -> IO (IO ())

505+onEventName en e = case en of

506+ Abort -> on e E.abort

507+ Blur -> on e E.blurEvent

508+ Change -> on e E.change

509+ Click -> on e E.click

510+ Contextmenu -> on e E.contextMenu

511+ Dblclick -> on e E.dblClick

512+ Drag -> on e E.drag

513+ Dragend -> on e E.dragEnd

514+ Dragenter -> on e E.dragEnter

515+ Dragleave -> on e E.dragLeave

516+ Dragover -> on e E.dragOver

517+ Dragstart -> on e E.dragStart

518+ Drop -> on e E.drop

519+ Error -> on e E.error

520+ Focus -> on e E.focusEvent

521+ Input -> on e E.input

522+ Invalid -> on e E.invalid

523+ Keydown -> on e E.keyDown

524+ Keypress -> on e E.keyPress

525+ Keyup -> on e E.keyUp

526+ Load -> on e E.load

527+ Mousedown -> on e E.mouseDown

528+ Mouseenter -> on e E.mouseEnter

529+ Mouseleave -> on e E.mouseLeave

530+ Mousemove -> on e E.mouseMove

531+ Mouseout -> on e E.mouseOut

532+ Mouseover -> on e E.mouseOver

533+ Mouseup -> on e E.mouseUp

534+ Mousewheel -> on e E.mouseWheel

535+ Scroll -> on e E.scroll

536+ Select -> on e E.select

537+ Submit -> on e E.submit

538+ Wheel -> on e E.wheel

539+ Beforecut -> on e E.beforeCut

540+ Cut -> on e E.cut

541+ Beforecopy -> on e E.beforeCopy

542+ Copy -> on e E.copy

543+ Beforepaste -> on e E.beforePaste

544+ Paste -> on e E.paste

545+ Reset -> on e E.reset

546+ Search -> on e E.search

547+ Selectstart -> on e E.selectStart

548+ Touchstart -> on e E.touchStart

549+ Touchmove -> on e E.touchMove

550+ Touchend -> on e E.touchEnd

551+ Touchcancel -> on e E.touchCancel

543552

544553newtype EventResult en = EventResult { unEventResult :: EventResultType en }

545554

@@ -588,42 +597,43 @@ type family EventResultType (en :: EventTag) :: * where

588597 EventResultType 'TouchmoveTag = ()

589598 EventResultType 'TouchendTag = ()

590599 EventResultType 'TouchcancelTag = ()

600+ EventResultType 'MousewheelTag = ()

601+ EventResultType 'WheelTag = ()

591602

592−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))

603+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))

593604wrapDomEventsMaybe element handlers = do

594605 postGui <- askPostGui

595606 runWithActions <- askRunWithActions

596607 e <- newFanEventWithTrigger $ \(WrapArg en) et -> do

597− unsubscribe <- liftIO $ (onEventName en) element $ do

608+ unsubscribe <- onEventName en element $ do

598609 mv <- handlers en

599− forM_ mv $ \v -> liftIO $ postGui $ runWithActions [et :=> v]

610+ forM_ mv $ \v -> liftIO $ postGui $ runWithActions [et :=> Identity v]

600611 return $ liftIO $ do

601612 unsubscribe

602613 return $! e

603614

604−getKeyEvent :: EventM UIEvent e Int

615+getKeyEvent :: EventM e KeyboardEvent Int

605616getKeyEvent = do

606617 e <- event

607− liftIO $ do

608− which <- uiEventGetWhich e

609− if which /= 0 then return which else do

610− charCode <- uiEventGetCharCode e

611− if charCode /= 0 then return charCode else

612− uiEventGetKeyCode e

613−

614−getMouseEventCoords :: EventM MouseEvent e (Int, Int)

618+ which <- getWhich e

619+ if which /= 0 then return which else do

620+ charCode <- getCharCode e

621+ if charCode /= 0 then return charCode else

622+ getKeyCode e

623+

624+getMouseEventCoords :: EventM e MouseEvent (Int, Int)

615625getMouseEventCoords = do

616626 e <- event

617− liftIO $ bisequence (mouseEventGetClientX e, mouseEventGetClientY e)

627+ bisequence (getX e, getY e)

618628

619−defaultDomEventHandler :: IsElement e => e -> EventName en -> EventM (EventType en) e (Maybe (EventResult en))

629+defaultDomEventHandler :: IsElement e => e -> EventName en -> EventM e (EventType en) (Maybe (EventResult en))

620630defaultDomEventHandler e evt = liftM (Just . EventResult) $ case evt of

621631 Click -> return ()

622632 Dblclick -> return ()

623633 Keypress -> getKeyEvent

634+ Scroll -> getScrollTop e

624635 Keydown -> getKeyEvent

625636 Keyup -> getKeyEvent

626− Scroll -> liftIO $ elementGetScrollTop e

627637 Mousemove -> getMouseEventCoords

628638 Mouseup -> getMouseEventCoords

629639 Mousedown -> getMouseEventCoords

@@ -662,8 +672,10 @@ defaultDomEventHandler e evt = liftM (Just . EventResult) $ case evt of

662672 Touchmove -> return ()

663673 Touchend -> return ()

664674 Touchcancel -> return ()

675+ Mousewheel -> return ()

676+ Wheel -> return ()

665677

666−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)

678+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)

667679wrapElement eh e = do

668680 es <- wrapDomEventsMaybe e $ eh e

669681 return $ El e es

@@ -748,17 +760,15 @@ simpleList xs mkChild = mapDyn (map snd . Map.toList) =<< flip list mkChild =<<

748760elDynHtml' :: MonadWidget t m => String -> Dynamic t String -> m (El t)

749761elDynHtml' elementTag html = do

750762 e <- buildEmptyElement elementTag (Map.empty :: Map String String)

751− let h = castToHTMLElement e

752− schedulePostBuild $ liftIO . htmlElementSetInnerHTML h =<< sample (current html)

753− addVoidAction $ fmap (liftIO . htmlElementSetInnerHTML h) $ updated html

763+ schedulePostBuild $ setInnerHTML e . Just =<< sample (current html)

764+ addVoidAction $ fmap (setInnerHTML e . Just) $ updated html

754765 wrapElement defaultDomEventHandler e

755766

756767elDynHtmlAttr' :: MonadWidget t m => String -> Map String String -> Dynamic t String -> m (El t)

757768elDynHtmlAttr' elementTag attrs html = do

758769 e <- buildEmptyElement elementTag attrs

759− let h = castToHTMLElement e

760− schedulePostBuild $ liftIO . htmlElementSetInnerHTML h =<< sample (current html)

761− addVoidAction $ fmap (liftIO . htmlElementSetInnerHTML h) $ updated html

770+ schedulePostBuild $ setInnerHTML e . Just =<< sample (current html)

771+ addVoidAction $ fmap (setInnerHTML e . Just) $ updated html

762772 wrapElement defaultDomEventHandler e

763773

764774data Link t

@@ -783,7 +793,7 @@ class HasDomEvent t a where

783793 domEvent :: EventName en -> a -> Event t (EventResultType en)

784794

785795instance Reflex t => HasDomEvent t (El t) where

786− domEvent en e = fmap unEventResult $ select (_el_events e) (WrapArg en)

796+ domEvent en e = fmap unEventResult $ Reflex.select (_el_events e) (WrapArg en)

787797

788798linkClass :: MonadWidget t m => String -> String -> m (Link t)

789799linkClass s c = do

@@ -871,7 +881,7 @@ tabDisplay ulClass activeClass tabItems = do

871881unsafePlaceElement :: MonadWidget t m => Element -> m (El t)

872882unsafePlaceElement e = do

873883 p <- askParent

874− _ <- liftIO $ nodeAppendChild p $ Just e

884+ _ <- appendChild p $ Just e

875885 wrapElement defaultDomEventHandler e

876886

877887deriveGEq ''EventName

src/Reflex/Dom/Widget/Input.hs+36−37

@@ -8,13 +8,13 @@ import Reflex.Dom.Widget.Basic

99import Reflex

1010import Reflex.Host.Class

11−import GHCJS.DOM.HTMLInputElement

12−import GHCJS.DOM.HTMLTextAreaElement

13−import GHCJS.DOM.Element

14−import GHCJS.DOM.HTMLSelectElement

11+import GHCJS.DOM.HTMLInputElement as Input

12+import GHCJS.DOM.HTMLTextAreaElement as TextArea

13+import GHCJS.DOM.Element hiding (error)

14+import GHCJS.DOM.HTMLSelectElement as Select

1515import GHCJS.DOM.EventM

1616import GHCJS.DOM.File

17−import GHCJS.DOM.FileList

17+import qualified GHCJS.DOM.FileList as FileList

1818import Data.Monoid

1919import Data.Map as Map

2020import Control.Lens

@@ -53,21 +53,21 @@ instance Reflex t => Default (TextInputConfig t) where

5353textInput :: MonadWidget t m => TextInputConfig t -> m (TextInput t)

5454textInput (TextInputConfig inputType initial eSetValue dAttrs) = do

5555 e <- liftM castToHTMLInputElement $ buildEmptyElement "input" =<< mapDyn (Map.insert "type" inputType) dAttrs

56− liftIO $ htmlInputElementSetValue e initial

57− performEvent_ $ fmap (liftIO . htmlInputElementSetValue e) eSetValue

58− eChange <- wrapDomEvent e elementOninput $ liftIO $ htmlInputElementGetValue e

56+ Input.setValue e $ Just initial

57+ performEvent_ $ fmap (Input.setValue e . Just) eSetValue

58+ eChange <- wrapDomEvent e (`on` input) $ fromMaybe "" <$> Input.getValue e

5959 postGui <- askPostGui

6060 runWithActions <- askRunWithActions

6161 eChangeFocus <- newEventWithTrigger $ \eChangeFocusTrigger -> do

62− unsubscribeOnblur <- liftIO $ elementOnblur e $ liftIO $ do

63− postGui $ runWithActions [eChangeFocusTrigger :=> False]

64− unsubscribeOnfocus <- liftIO $ elementOnfocus e $ liftIO $ do

65− postGui $ runWithActions [eChangeFocusTrigger :=> True]

62+ unsubscribeOnblur <- on e blurEvent $ liftIO $ do

63+ postGui $ runWithActions [eChangeFocusTrigger :=> Identity False]

64+ unsubscribeOnfocus <- on e focusEvent $ liftIO $ do

65+ postGui $ runWithActions [eChangeFocusTrigger :=> Identity True]

6666 return $ liftIO $ unsubscribeOnblur >> unsubscribeOnfocus

6767 dFocus <- holdDyn False eChangeFocus

68− eKeypress <- wrapDomEvent e elementOnkeypress getKeyEvent

69− eKeydown <- wrapDomEvent e elementOnkeydown getKeyEvent

70− eKeyup <- wrapDomEvent e elementOnkeyup getKeyEvent

68+ eKeypress <- wrapDomEvent e (`on` keyPress) getKeyEvent

69+ eKeydown <- wrapDomEvent e (`on` keyDown) getKeyEvent

70+ eKeyup <- wrapDomEvent e (`on` keyUp) getKeyEvent

7171 dValue <- holdDyn initial $ leftmost [eSetValue, eChange]

7272 return $ TextInput dValue eChange eKeypress eKeydown eKeyup dFocus e

7373

@@ -97,20 +97,20 @@ data TextArea t

9797textArea :: MonadWidget t m => TextAreaConfig t -> m (TextArea t)

9898textArea (TextAreaConfig initial eSet attrs) = do

9999 e <- liftM castToHTMLTextAreaElement $ buildEmptyElement "textarea" attrs

100− liftIO $ htmlTextAreaElementSetValue e initial

100+ TextArea.setValue e $ Just initial

101101 postGui <- askPostGui

102102 runWithActions <- askRunWithActions

103103 eChangeFocus <- newEventWithTrigger $ \eChangeFocusTrigger -> do

104− unsubscribeOnblur <- liftIO $ elementOnblur e $ liftIO $ do

105− postGui $ runWithActions [eChangeFocusTrigger :=> False]

106− unsubscribeOnfocus <- liftIO $ elementOnfocus e $ liftIO $ do

107− postGui $ runWithActions [eChangeFocusTrigger :=> True]

104+ unsubscribeOnblur <- on e blurEvent $ liftIO $ do

105+ postGui $ runWithActions [eChangeFocusTrigger :=> Identity False]

106+ unsubscribeOnfocus <- on e focusEvent $ liftIO $ do

107+ postGui $ runWithActions [eChangeFocusTrigger :=> Identity True]

108108 return $ liftIO $ unsubscribeOnblur >> unsubscribeOnfocus

109− performEvent_ $ fmap (liftIO . htmlTextAreaElementSetValue e) eSet

109+ performEvent_ $ fmap (TextArea.setValue e . Just) eSet

110110 f <- holdDyn False eChangeFocus

111− ev <- wrapDomEvent e elementOninput $ liftIO $ htmlTextAreaElementGetValue e

111+ ev <- wrapDomEvent e (`on` input) $ fromMaybe "" <$> TextArea.getValue e

112112 v <- holdDyn initial $ leftmost [eSet, ev]

113− eKeypress <- wrapDomEvent e elementOnkeypress getKeyEvent

113+ eKeypress <- wrapDomEvent e (`on` keyPress) getKeyEvent

114114 return $ TextArea v ev e f eKeypress

115115

116116data CheckboxConfig t

@@ -135,21 +135,21 @@ checkbox :: MonadWidget t m => Bool -> CheckboxConfig t -> m (Checkbox t)

135135checkbox checked config = do

136136 attrs <- mapDyn (\c -> Map.insert "type" "checkbox" $ (if checked then Map.insert "checked" "checked" else Map.delete "checked") c) (_checkboxConfig_attributes config)

137137 e <- liftM castToHTMLInputElement $ buildEmptyElement "input" attrs

138− eClick <- wrapDomEvent e elementOnclick $ liftIO $ htmlInputElementGetChecked e

139− performEvent_ $ fmap (\v -> liftIO $ htmlInputElementSetChecked e $! v) $ _checkboxConfig_setValue config

138+ eClick <- wrapDomEvent e (`on` click) $ Input.getChecked e

139+ performEvent_ $ fmap (\v -> Input.setChecked e $! v) $ _checkboxConfig_setValue config

140140 dValue <- holdDyn checked $ leftmost [_checkboxConfig_setValue config, eClick]

141141 return $ Checkbox dValue eClick

142142

143143checkboxView :: MonadWidget t m => Dynamic t (Map String String) -> Dynamic t Bool -> m (Event t Bool)

144144checkboxView dAttrs dValue = do

145145 e <- liftM castToHTMLInputElement $ buildEmptyElement "input" =<< mapDyn (Map.insert "type" "checkbox") dAttrs

146− eClicked <- wrapDomEvent e elementOnclick $ do

146+ eClicked <- wrapDomEvent e (`on` click) $ do

147147 preventDefault

148− liftIO $ htmlInputElementGetChecked e

148+ Input.getChecked e

149149 schedulePostBuild $ do

150150 v <- sample $ current dValue

151− when v $ liftIO $ htmlInputElementSetChecked e True

152− performEvent_ $ fmap (\v -> liftIO $ htmlInputElementSetChecked e $! v) $ updated dValue

151+ when v $ Input.setChecked e True

152+ performEvent_ $ fmap (\v -> Input.setChecked e $! v) $ updated dValue

153153 return eClicked

154154

155155data FileInput t

@@ -168,10 +168,10 @@ instance Reflex t => Default (FileInputConfig t) where

168168fileInput :: MonadWidget t m => FileInputConfig t -> m (FileInput t)

169169fileInput (FileInputConfig dAttrs) = do

170170 e <- liftM castToHTMLInputElement $ buildEmptyElement "input" =<< mapDyn (Map.insert "type" "file") dAttrs

171− eChange <- wrapDomEvent e elementOnchange $ liftIO $ do

172− Just files <- htmlInputElementGetFiles e

173− len <- fileListGetLength files

174− mapM (liftM (fromMaybe (error "fileInput: fileListItem returned null")) . fileListItem files) $ init [0..len]

171+ eChange <- wrapDomEvent e (flip on change) $ do

172+ Just files <- getFiles e

173+ len <- FileList.getLength files

174+ mapM (liftM (fromMaybe (error "fileInput: fileListItem returned null")) . FileList.item files) $ init [0..len]

175175 dValue <- holdDyn [] eChange

176176 return $ FileInput dValue e

177177

@@ -201,9 +201,9 @@ dropdown k0 options (DropdownConfig setK attrs) = do

201201 listWithKey optionsWithDefault $ \k v -> do

202202 elAttr "option" ("value" =: show k <> if k == k0 then "selected" =: "selected" else mempty) $ dynText v

203203 let e = castToHTMLSelectElement $ _el_element eRaw

204− performEvent_ $ fmap (liftIO . htmlSelectElementSetValue e . show) setK

205− eChange <- wrapDomEvent e elementOnchange $ do

206− kStr <- liftIO $ htmlSelectElementGetValue e

204+ performEvent_ $ fmap (Select.setValue e . Just . show) setK

205+ eChange <- wrapDomEvent e (`on` change) $ do

206+ kStr <- fromMaybe "" <$> Select.getValue e

207207 return $ readMay kStr

208208 let readKey opts mk = fromMaybe k0 $ do

209209 k <- mk

@@ -326,4 +326,3 @@ instance HasStateModeWitness Edit where

326326instance HasStateModeWitness View where

327327 stateModeWitness = ViewWitness

328328-}

329−

src/Reflex/Dom/Widget/Lazy.hs+2−2

@@ -49,7 +49,7 @@ virtualListWithSelection heightPx rowPx maxIndex i0 setI listTag listAttrs rowTa

4949 window <- combineDyn (\h -> findWindow h rowPx) heightPx scrollPosition

5050 itemsInWindow <- combineDyn (\(_,(idx,num)) is -> Map.fromList $ map (\i -> let ix = indexToKey i in (ix, Map.lookup ix is)) [idx .. idx + num]) window items

5151 postBuild <- getPostBuild

52− performEvent_ $ fmap (\i -> liftIO $ elementSetScrollTop (_el_element container) (i * rowPx)) $ leftmost [setI, fmap (const i0) postBuild]

52+ performEvent_ $ fmap (\i -> liftIO $ setScrollTop (_el_element container) (i * rowPx)) $ leftmost [setI, fmap (const i0) postBuild]

5353 indexAndLength <- mapDyn snd window

5454 return (indexAndLength, sel)

5555 where

@@ -92,7 +92,7 @@ virtualList heightPx rowPx maxIndex i0 setI keyToIndex items0 itemsUpdate itemBu

9292 , fmap (const (i0 * rowPx)) pb

9393 ]

9494 window <- combineDyn (\h -> findWindow h rowPx) heightPx scrollPosition

95− performEvent_ $ fmap (\i -> liftIO $ elementSetScrollTop (_el_element viewport) (i * rowPx)) $ leftmost [setI, fmap (const i0) pb]

95+ performEvent_ $ fmap (\i -> liftIO $ setScrollTop (_el_element viewport) (i * rowPx)) $ leftmost [setI, fmap (const i0) pb]

9696 return (nubDyn window, result)

9797 where

9898 toStyleAttr m = "style" =: (Map.foldWithKey (\k v s -> k <> ":" <> v <> ";" <> s) "" m)

src/Reflex/Dom/Widget/Resize.hs+19−18

@@ -8,7 +8,8 @@ import Reflex.Dom.Widget.Basic

88import Control.Monad

99import Control.Monad.IO.Class

1010import Data.Monoid

11−import GHCJS.DOM.Element

11+import GHCJS.DOM.Element hiding (reset)

12+import GHCJS.DOM.EventM (on)

1213

1314-- | A widget that wraps the given widget in a div and fires an event when resized.

1415-- Adapted from github.com/marcj/css-element-queries

@@ -31,31 +32,31 @@ resizeDetectorWithStyle styleString w = do

3132 let reset = do

3233 let e = _el_element expand

3334 s = _el_element shrink

34− eow <- elementGetOffsetWidth e

35− eoh <- elementGetOffsetHeight e

35+ eow <- getOffsetWidth e

36+ eoh <- getOffsetHeight e

3637 let ecw = eow + 10

3738 ech = eoh + 10

38− elementSetAttribute (_el_element expandChild) "style" (childStyle <> "width: " <> show ecw <> "px;" <> "height: " <> show ech <> "px;")

39− esw <- elementGetScrollWidth e

40− elementSetScrollLeft e esw

41− esh <- elementGetScrollHeight e

42− elementSetScrollTop e esh

43− ssw <- elementGetScrollWidth s

44− elementSetScrollLeft s ssw

45− ssh <- elementGetScrollHeight s

46− elementSetScrollTop s ssh

47− lastWidth <- elementGetOffsetWidth (_el_element parent)

48− lastHeight <- elementGetOffsetHeight (_el_element parent)

39+ setAttribute (_el_element expandChild) "style" (childStyle <> "width: " <> show ecw <> "px;" <> "height: " <> show ech <> "px;")

40+ esw <- getScrollWidth e

41+ setScrollLeft e esw

42+ esh <- getScrollHeight e

43+ setScrollTop e esh

44+ ssw <- getScrollWidth s

45+ setScrollLeft s ssw

46+ ssh <- getScrollHeight s

47+ setScrollTop s ssh

48+ lastWidth <- getOffsetWidth (_el_element parent)

49+ lastHeight <- getOffsetHeight (_el_element parent)

4950 return (Just lastWidth, Just lastHeight)

5051 resetIfChanged ds = do

51− pow <- elementGetOffsetWidth (_el_element parent)

52− poh <- elementGetOffsetHeight (_el_element parent)

52+ pow <- getOffsetWidth (_el_element parent)

53+ poh <- getOffsetHeight (_el_element parent)

5354 if ds == (Just pow, Just poh)

5455 then return Nothing

5556 else liftM Just reset

5657 pb <- getPostBuild

57− expandScroll <- wrapDomEvent (_el_element expand) elementOnscroll $ return ()

58− shrinkScroll <- wrapDomEvent (_el_element shrink) elementOnscroll $ return ()

58+ expandScroll <- wrapDomEvent (_el_element expand) (`on` scroll) $ return ()

59+ shrinkScroll <- wrapDomEvent (_el_element shrink) (`on` scroll) $ return ()

5960 size0 <- performEvent $ fmap (const $ liftIO reset) pb

6061 rec resize <- performEventAsync $ fmap (\d cb -> liftIO $ cb =<< resetIfChanged d) $ tag (current dimensions) $ leftmost [expandScroll, shrinkScroll]

6162 dimensions <- holdDyn (Nothing, Nothing) $ leftmost [ size0, fmapMaybe id resize ]

src/Reflex/Dom/Xhr.hs+131−21

@@ -1,8 +1,28 @@

11{-# LANGUAGE TemplateHaskell, GADTs, DeriveDataTypeable #-}

22module Reflex.Dom.Xhr

3− ( module Reflex.Dom.Xhr

4− , XMLHttpRequest

5− , responseTextToText

3+ ( XMLHttpRequest

4+ , XhrRequest(..)

5+ , XhrRequestConfig(..)

6+ , XhrResponse(..)

7+ , XhrResponseBody(..)

8+ , XhrResponseType(..)

9+ , XhrException(..)

10+ , _xhrResponse_body

11+ , xhrResponse_body

12+ , xhrRequest

13+ , newXMLHttpRequest

14+ , newXMLHttpRequestWithError

15+ , performRequestAsync

16+ , performMkRequestAsync

17+ , performRequestAsyncWithError

18+ , performRequestsAsync

19+ , performMkRequestsAsync

20+ , performRequestsAsyncWithError

21+ , getAndDecode

22+ , postJson

23+ , getMay

24+ , decodeText

25+ , decodeXhrResponse

626 , xmlHttpRequestGetReadyState

727 , xmlHttpRequestGetResponseText

828 , xmlHttpRequestGetStatus

@@ -13,6 +33,18 @@ module Reflex.Dom.Xhr

1333 , xmlHttpRequestSend

1434 , xmlHttpRequestSetRequestHeader

1535 , xmlHttpRequestSetResponseType

36+ , xhrRequest_config

37+ , xhrRequest_method

38+ , xhrRequest_url

39+ , xhrRequestConfig_headers

40+ , xhrRequestConfig_password

41+ , xhrRequestConfig_responseType

42+ , xhrRequestConfig_sendData

43+ , xhrRequestConfig_user

44+ , xhrResponse_response

45+ , xhrResponse_responseText

46+ , xhrResponse_status

47+ , xhrResponse_statusText

1648 )

1749where

1850

@@ -21,6 +53,7 @@ import Reflex.Dom.Class

2153import Reflex.Dom.Xhr.Foreign

2254

2355import Control.Concurrent

56+import Control.Exception (catch)

2457import Control.Lens

2558import Control.Monad hiding (forM)

2659import Control.Monad.IO.Class

@@ -36,6 +69,8 @@ import Data.Maybe

3669import Data.Text (Text)

3770import Data.Text.Encoding

3871import Data.Traversable

72+import Reflex.Dom.Xhr.Exception

73+import Reflex.Dom.Xhr.ResponseType

3974import Data.Typeable

4075

4176data XhrRequest a

@@ -49,17 +84,26 @@ data XhrRequestConfig a

4984 = XhrRequestConfig { _xhrRequestConfig_headers :: Map String String

5085 , _xhrRequestConfig_user :: Maybe String

5186 , _xhrRequestConfig_password :: Maybe String

52− , _xhrRequestConfig_responseType :: Maybe String

87+ , _xhrRequestConfig_responseType :: Maybe XhrResponseType

5388 , _xhrRequestConfig_sendData :: a

5489 }

5590 deriving (Show, Read, Eq, Ord, Typeable)

5691

5792data XhrResponse

58− = XhrResponse { _xhrResponse_body :: Maybe Text

59− , _xhrResponse_status :: Word

93+ = XhrResponse { _xhrResponse_status :: Word

6094 , _xhrResponse_statusText :: Text

95+ , _xhrResponse_response :: Maybe XhrResponseBody

96+ , _xhrResponse_responseText :: Maybe Text

6197 }

62− deriving (Show, Read, Eq, Ord, Typeable)

98+ deriving (Typeable)

99+

100+{-# DEPRECATED _xhrResponse_body "Use _xhrResponse_response or _xhrResponse_responseText instead." #-}

101+_xhrResponse_body :: XhrResponse -> Maybe Text

102+_xhrResponse_body = _xhrResponse_responseText

103+

104+{-# DEPRECATED xhrResponse_body "Use xhrResponse_response or xhrResponse_responseText instead." #-}

105+xhrResponse_body :: Lens XhrResponse XhrResponse (Maybe Text) (Maybe Text)

106+xhrResponse_body = lens _xhrResponse_responseText (\r t -> r { _xhrResponse_responseText = t })

63107

64108instance a ~ () => Default (XhrRequestConfig a) where

65109 def = XhrRequestConfig { _xhrRequestConfig_headers = Map.empty

@@ -73,13 +117,26 @@ instance a ~ () => Default (XhrRequestConfig a) where

73117xhrRequest :: String -> String -> XhrRequestConfig a -> XhrRequest a

74118xhrRequest = XhrRequest

75119

76−newXMLHttpRequest :: (HasWebView m, MonadIO m, HasPostGui t h m, IsXhrPayload a) => XhrRequest a -> (XhrResponse -> h ()) -> m XMLHttpRequest

77−newXMLHttpRequest req cb = do

120+-- | Make a new asyncronous XHR request. This does not block (it forks),

121+-- and returns an XHR object immediately (which you can use to abort

122+-- the XHR connection), and will pass an exception ('XhrException') to the

123+-- continuation if the connection cannot be made (or is aborted).

124+newXMLHttpRequestWithError

125+ :: (HasWebView m, MonadIO m, HasPostGui t h m, IsXhrPayload a)

126+ => XhrRequest a

127+ -- ^ The request to make.

128+ -> (Either XhrException XhrResponse -> h ())

129+ -- ^ A continuation to be called once a response comes back, or in

130+ -- case of error.

131+ -> m XMLHttpRequest

132+ -- ^ The XHR request, which could for example be aborted.

133+newXMLHttpRequestWithError req cb = do

78134 wv <- askWebView

79135 postGui <- askPostGui

80− liftIO $ do

81− xhr <- xmlHttpRequestNew $ unWebViewSingleton wv

136+ xhr <- liftIO $ xmlHttpRequestNew $ unWebViewSingleton wv

137+ void $ liftIO $ forkIO $ flip catch (postGui . cb . Left) $ void $ do

82138 let c = _xhrRequest_config req

139+ rt = _xhrRequestConfig_responseType c

83140 xmlHttpRequestOpen

84141 xhr

85142 (_xhrRequest_method req)

@@ -88,32 +145,85 @@ newXMLHttpRequest req cb = do

88145 (fromMaybe "" $ _xhrRequestConfig_user c)

89146 (fromMaybe "" $ _xhrRequestConfig_password c)

90147 iforM_ (_xhrRequestConfig_headers c) $ xmlHttpRequestSetRequestHeader xhr

91− maybe (return ()) (xmlHttpRequestSetResponseType xhr . toResponseType) (_xhrRequestConfig_responseType c)

148+ maybe (return ()) (xmlHttpRequestSetResponseType xhr . toResponseType) rt

92149 _ <- xmlHttpRequestOnreadystatechange xhr $ do

93150 readyState <- liftIO $ xmlHttpRequestGetReadyState xhr

94151 status <- liftIO $ xmlHttpRequestGetStatus xhr

95152 statusText <- liftIO $ xmlHttpRequestGetStatusText xhr

96153 if readyState == 4

97154 then do

98− r <- liftIO $ xmlHttpRequestGetResponseText xhr

99− _ <- liftIO $ postGui $ cb $ XhrResponse (responseTextToText r) status (statusTextToText statusText)

155+ t <- if rt == Just XhrResponseType_Text || rt == Nothing

156+ then liftIO $ xmlHttpRequestGetResponseText xhr

157+ else return Nothing

158+ r <- liftIO $ xmlHttpRequestGetResponse xhr

159+ _ <- liftIO $ postGui $ cb $ Right $

160+ XhrResponse { _xhrResponse_status = status

161+ , _xhrResponse_statusText = statusText

162+ , _xhrResponse_response = r

163+ , _xhrResponse_responseText = t

164+ }

100165 return ()

101166 else return ()

102167 _ <- xmlHttpRequestSend xhr (_xhrRequestConfig_sendData c)

103− return xhr

168+ return ()

169+ return xhr

170+

171+newXMLHttpRequest :: (HasWebView m, MonadIO m, HasPostGui t h m, IsXhrPayload a) => XhrRequest a -> (XhrResponse -> h ()) -> m XMLHttpRequest

172+newXMLHttpRequest req cb = newXMLHttpRequestWithError req $ mapM_ cb

173+

174+-- | Given Event of requests, issue them when the Event fires.

175+-- Returns Event of corresponding responses.

176+--

177+-- The request is processed asynchronously, therefore handling does

178+-- not block or cause a delay while creating the connection.

179+performRequestAsyncWithError

180+ :: (MonadWidget t m, IsXhrPayload a)

181+ => Event t (XhrRequest a)

182+ -> m (Event t (Either XhrException XhrResponse))

183+performRequestAsyncWithError = performRequestAsync' newXMLHttpRequestWithError . fmap return

104184

105185-- | Given Event of request, issue them when the Event fires. Returns Event of corresponding response.

106186performRequestAsync :: (MonadWidget t m, IsXhrPayload a) => Event t (XhrRequest a) -> m (Event t XhrResponse)

107−performRequestAsync req = performEventAsync $ ffor req $ \r cb -> do

108− _ <- newXMLHttpRequest r $ liftIO . cb

187+performRequestAsync = performRequestAsync' newXMLHttpRequest . fmap return

188+

189+-- | Given Event with an action that creates a request, build and issue the request when the Event fires. Returns Event of corresponding response.

190+performMkRequestAsync :: (MonadWidget t m, IsXhrPayload a) => Event t (WidgetHost m (XhrRequest a)) -> m (Event t XhrResponse)

191+performMkRequestAsync = performRequestAsync' newXMLHttpRequest

192+

193+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)

194+performRequestAsync' newXhr req = performEventAsync $ ffor req $ \hr cb -> do

195+ r <- hr

196+ newXhr r $ liftIO . cb

109197 return ()

110198

199+-- | Issues a collection of requests when the supplied Event fires.

200+-- When ALL requests from a given firing complete, the results are

201+-- collected and returned via the return Event.

202+--

203+-- The requests are processed asynchronously, therefore handling does

204+-- not block or cause a delay while creating the connection.

205+--

206+-- Order of request execution and completion is not guaranteed, but

207+-- order of creation and the collection result is preserved.

208+performRequestsAsyncWithError

209+ :: (Traversable f, MonadWidget t m, IsXhrPayload a)

210+ => Event t (f (XhrRequest a)) -> m (Event t (f (Either XhrException XhrResponse)))

211+performRequestsAsyncWithError = performRequestsAsync' newXMLHttpRequestWithError . fmap return

212+

111213-- | 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.

112214performRequestsAsync :: (Traversable f, MonadWidget t m, IsXhrPayload a) => Event t (f (XhrRequest a)) -> m (Event t (f XhrResponse))

113−performRequestsAsync req = performEventAsync $ ffor req $ \rs cb -> do

215+performRequestsAsync = performRequestsAsync' newXMLHttpRequest . fmap return

216+

217+-- | 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.

218+performMkRequestsAsync :: (Traversable f, MonadWidget t m, IsXhrPayload a) => Event t (WidgetHost m (f (XhrRequest a))) -> m (Event t (f XhrResponse))

219+performMkRequestsAsync = performRequestsAsync' newXMLHttpRequest

220+

221+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))

222+performRequestsAsync' newXhr req = performEventAsync $ ffor req $ \hrs cb -> do

223+ rs <- hrs

114224 resps <- forM rs $ \r -> do

115225 resp <- liftIO newEmptyMVar

116− _ <- newXMLHttpRequest r $ liftIO . putMVar resp

226+ _ <- newXhr r $ liftIO . putMVar resp

117227 return resp

118228 _ <- liftIO $ forkIO $ cb =<< forM resps takeMVar

119229 return ()

@@ -126,7 +236,7 @@ getAndDecode url = do

126236

127237-- | Create a "POST" request from an URL and thing with a JSON representation

128238postJson :: (ToJSON a) => String -> a -> XhrRequest String

129−postJson url a =

239+postJson url a =

130240 XhrRequest "POST" url $ def { _xhrRequestConfig_headers = headerUrlEnc

131241 , _xhrRequestConfig_sendData = body

132242 }

@@ -143,7 +253,7 @@ decodeText = decode . BL.fromStrict . encodeUtf8

143253

144254-- | Convenience function to decode JSON-encoded responses.

145255decodeXhrResponse :: FromJSON a => XhrResponse -> Maybe a

146−decodeXhrResponse = join . fmap decodeText . _xhrResponse_body

256+decodeXhrResponse = join . fmap decodeText . _xhrResponse_responseText

147257

148258liftM concat $ mapM makeLenses

149259 [ ''XhrRequest

src/Reflex/Dom/Xhr/Exception.hsnew file+12

@@ -0,0 +1,12 @@

1+{-# LANGUAGE DeriveDataTypeable #-}

3+module Reflex.Dom.Xhr.Exception where

5+import Data.Typeable

6+import Control.Exception (Exception(..))

8+data XhrException = XhrException_Error

9+ | XhrException_Aborted

10+ deriving (Show, Read, Eq, Ord, Typeable)

11+

12+instance Exception XhrException

src/Reflex/Dom/Xhr/ResponseType.hsnew file+14

@@ -0,0 +1,14 @@

1+{-# LANGUAGE DeriveDataTypeable #-}

3+module Reflex.Dom.Xhr.ResponseType where

5+import Data.Typeable

7+data XhrResponseType = XhrResponseType_Default

8+ | XhrResponseType_ArrayBuffer

9+ | XhrResponseType_Blob

10+ | XhrResponseType_Document

11+ | XhrResponseType_JSON

12+ | XhrResponseType_Text

13+ deriving (Show, Read, Eq, Ord, Typeable)

14+

test/BrokenHaltSpec.hsnew file+40

@@ -0,0 +1,40 @@

1+{-# LANGUAGE FlexibleContexts #-}

3+module HaltSpec where

5+import Control.Monad.IO.Class

6+import Data.Foldable

7+import GHCJS.DOM

8+import qualified Graphics.UI.Gtk as Gtk

9+import Reflex.Dom

10+import Reflex.Spider.Internal (SpiderHostFrame)

11+import Test.Hspec

12+

13+spec :: Spec

14+spec = do

15+ describe "haltGui" $ do

16+ it "works" $ do

17+ getFirstEventAndHalt return `shouldReturn` ()

18+

19+ it "works multiple times" $ do

20+ forM_ [1 .. 100] $ \ i -> do

21+ getFirstEventAndHalt return `shouldReturn` ()

22+

23+type SpiderM =

24+ Widget Spider (Gui Spider (WithWebView SpiderHost) SpiderHostFrame)

25+

26+getFirstEventAndHalt :: (Event Spider () -> SpiderM (Event Spider ())) -> IO ()

27+getFirstEventAndHalt action = do

28+ _ <- mainWidget $ do

29+ tick <- getPostBuild

30+ event <- action tick

31+ webView <- askWebView

32+ _ <- foldDynM (\ a () -> liftIO $ haltGui webView) () event

33+ return ()

34+ return ()

35+

36+haltGui :: WebView -> IO ()

37+haltGui wv = do

38+ Gtk.postGUIAsync $ do

39+ w <- Gtk.widgetGetToplevel wv

40+ Gtk.widgetDestroy w

test/HaltSpec.hsnew file+29

@@ -0,0 +1,29 @@

1+{-# LANGUAGE FlexibleContexts #-}

3+import Control.Monad.IO.Class

4+import Data.Foldable

5+import GHCJS.DOM

6+import qualified Graphics.UI.Gtk as Gtk

7+import Reflex.Dom

8+import Reflex.Spider.Internal (SpiderHostFrame)

10+main = do

11+ getFirstEventAndHalt return

12+ putStrLn "stopped once"

13+

14+ forM_ [1 .. 1000] $ \ i -> do

15+ getFirstEventAndHalt return

16+ putStrLn "stopped many times"

17+

18+type SpiderM = Widget Spider (Gui Spider (WithWebView SpiderHost) SpiderHostFrame)

19+

20+getFirstEventAndHalt :: (Event Spider () -> SpiderM (Event Spider ())) -> IO ()

21+getFirstEventAndHalt action = do

22+ _ <- mainWidget $ do

23+ tick <- getPostBuild

24+ event <- action tick

25+ webView <- askWebView

26+ quit <- getQuitWidget

27+ performEvent_ (quit <$ event)

28+ return ()

29+ return ()