5903797 · reflex-dom · git.iko.soy

git.iko.soy/reflex-dom

on develop help sign in

Merge branch 'develop' into HEAD

5903797Ryan Trinkle11 years ago

default.nix+3−3

compare with develop

unifiedsplit

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

3, transformers, data-default, semigroups, aeson

4, ghc, webkitgtk3-javascriptcore, exception-transformers

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

6−, random

6+, random, raw-strings-qq

7}:

9mkDerivation {

10 pname = "reflex-dom";

11− version = "0.2";

11+ version = "0.3";

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

13 buildDepends = [

14 reflex

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

29 bifunctors

30 zenc

31 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 ]);

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

34 license = null;

35}

reflex-dom.cabal+18−12

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

1Name: reflex-dom

2−Version: 0.2

2+Version: 0.3

3Synopsis: Functional Reactive Web Apps with Reflex

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

5License: BSD3

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

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

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

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

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

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

19library

21library

20 hs-source-dirs: src

22 hs-source-dirs: src

21 build-depends:

23 build-depends:

22 base >= 4.7 && < 4.9,

24 base >= 4.7 && < 4.9,

23 template-haskell,

25 template-haskell,

24− reflex == 0.3.*,

26+ reflex == 0.4.*,

25− dependent-sum == 0.2.*,

27+ dependent-sum == 0.3.*,

26− dependent-map == 0.1.*,

28+ dependent-map == 0.2.*,

27− semigroups == 0.16.*,

29+ semigroups >= 0.16 && < 0.19,

28 mtl >= 2.1 && < 2.3,

30 mtl >= 2.1 && < 2.3,

29 containers == 0.5.*,

31 containers == 0.5.*,

30 these >= 0.4 && < 0.7,

32 these >= 0.4 && < 0.7,

31 ref-tf == 0.4.*,

33 ref-tf == 0.4.*,

32 random == 1.1.*,

34 random == 1.1.*,

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

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

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

34 lens >= 4.7 && < 4.14,

37 lens >= 4.7 && < 4.14,

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

36 safe == 0.3.*,

38 safe == 0.3.*,

37 text == 1.2.*,

39 text == 1.2.*,

38 bytestring == 0.10.*,

40 bytestring == 0.10.*,

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

43 directory == 1.2.*,

45 directory == 1.2.*,

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

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

45 zenc == 0.1.*,

47 zenc == 0.1.*,

46− bifunctors >= 4.2 && < 5.1

48+ bifunctors >= 4.2 && < 6

48 if impl(ghcjs)

50 if impl(ghcjs)

49 hs-source-dirs: src-ghcjs

51 hs-source-dirs: src-ghcjs

50− cpp-options: -D__GHCJS__

51 build-depends:

52 build-depends:

52 ghcjs-base,

53 ghcjs-base,

53 hashable == 1.2.*

54 hashable == 1.2.*

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

55 hs-source-dirs: src-ghc

56 hs-source-dirs: src-ghc

56 build-depends:

57 build-depends:

57 glib == 0.13.*,

58 glib == 0.13.*,

58− gtk3 == 0.13.*,

59+ gtk3 >= 0.13.0 && < 0.15,

59− webkitgtk3 == 0.13.*,

60+ webkitgtk3 == 0.14.*,

60− webkitgtk3-javascriptcore == 0.13.*

61+ webkitgtk3-javascriptcore == 0.13.*,

62+ raw-strings-qq

61 pkgconfig-depends:

63 pkgconfig-depends:

62 webkitgtk-3.0 >= 1.8

64 webkitgtk-3.0 >= 1.8

65+ if !os(windows)

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

64 exposed-modules:

68 exposed-modules:

65 Reflex.Dom

69 Reflex.Dom

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

80 Reflex.Dom.Internal.Foreign

84 Reflex.Dom.Internal.Foreign

81 Reflex.Dom.WebSocket.Foreign

85 Reflex.Dom.WebSocket.Foreign

82 Reflex.Dom.Xhr.Foreign

86 Reflex.Dom.Xhr.Foreign

87+ Reflex.Dom.Xhr.ResponseType

88+ Reflex.Dom.Xhr.Exception

84 other-extensions: TemplateHaskell

90 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

87source-repository head

93source-repository head

88 type: git

94 type: git

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

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

1−{-# LANGUAGE ForeignFunctionInterface #-}

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

2module Reflex.Dom.Internal.Foreign where

4import Control.Lens hiding (set)

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

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

8import Foreign.Ptr

9import GHCJS.DOM.Navigator

10−import GHCJS.DOM.DOMWindow

10+import GHCJS.DOM.Window

11import Graphics.UI.Gtk hiding (Widget)

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

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

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

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

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

17import 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)

19import Graphics.UI.Gtk.WebKit.WebSettings

20import Graphics.UI.Gtk.WebKit.WebFrame

21import Graphics.UI.Gtk.WebKit.WebInspector

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

23import System.Directory

24import System.Glib.FFI hiding (void)

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+

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

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

27makeDefaultWebView userAgentKey main = do

42makeDefaultWebView userAgentKey main = do

28 _ <- initGUI

43 _ <- initGUI

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

58 wf <- webViewGetMainFrame webView

73 wf <- webViewGetMainFrame webView

59 pwd <- getCurrentDirectory

74 pwd <- getCurrentDirectory

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

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

76+ installQuitHandler webView

61 mainGUI

77 mainGUI

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

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

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

70 case mbWindow of

86 case mbWindow of

71 Just window -> do

87 Just window -> do

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

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

73− Just n <- domWindowGetNavigator window

89+ Just n <- getNavigator window

74− agent <- navigatorGetUserAgent n

90+ agent <- getUserAgent n

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

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

76 Nothing -> do

92 Nothing -> do

77 makeDefaultWebView userAgentKey main

93 makeDefaultWebView userAgentKey main

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

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

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

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

2−module Reflex.Dom.Xhr.Foreign where

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

3+ , XhrResponseType

4+ ) where

4−import Control.Lens.Indexed

5import qualified Data.Text as T

6import qualified Data.Text as T

6import Data.Text (Text)

7import Data.Text (Text)

7import System.Glib.FFI

8import System.Glib.FFI

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

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

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

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

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

14import GHCJS.DOM.File

15import 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

16import Reflex.Dom.Internal.Foreign

21import Reflex.Dom.Internal.Foreign

23+import Text.RawString.QQ

24+

18data XMLHttpRequest

25data XMLHttpRequest

19 = XMLHttpRequest { xhrValue :: JSValueRef

26 = XMLHttpRequest { xhrValue :: JSValueRef

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

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

21 }

28 }

22 deriving (Eq, Ord)

29 deriving (Eq, Ord)

24−responseTextToText :: Maybe String -> Maybe Text

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

25−responseTextToText = fmap T.pack

26−

27−statusTextToText :: String -> Text

28−statusTextToText = T.pack

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

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

31stringToJSValue ctx s = jsvaluemakestring ctx =<< jsstringcreatewithutf8cstring s

34stringToJSValue ctx s = jsvaluemakestring ctx =<< jsstringcreatewithutf8cstring s

33−toResponseType :: a -> a

36+toResponseType :: XhrResponseType -> String

34−toResponseType = id

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"

36xmlHttpRequestNew :: WebView -> IO XMLHttpRequest

44xmlHttpRequestNew :: WebView -> IO XMLHttpRequest

37xmlHttpRequestNew wv = do

45xmlHttpRequestNew wv = do

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

75 d <- jsvaluetonumber c rs nullPtr

83 d <- jsvaluetonumber c rs nullPtr

76 return $ truncate d

84 return $ truncate d

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+

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

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

79xmlHttpRequestGetResponseText xhr = do

97xmlHttpRequestGetResponseText xhr = do

80 let c = xhrContext xhr

98 let c = xhrContext xhr

81 script <- jsstringcreatewithutf8cstring "this.responseText"

99 script <- jsstringcreatewithutf8cstring "this.responseText"

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

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

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

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

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

91 peekCString ps

109 peekCString ps

92− return $ Just s

110+ return $ Just $ T.pack s

111

94class IsXhrPayload a where

112class IsXhrPayload a where

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

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

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

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

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

107xmlHttpRequestSendPayload xhr payload = do

125xmlHttpRequestSendPayload xhr payload = do

108 let c = xhrContext xhr

126 let c = xhrContext xhr

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

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

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

110− Nothing -> do

136+ Nothing -> do

137+ d <- jsvaluemakeundefined c

111− o <- toJSObject c [xhrValue xhr]

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

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

139+ s <- jsstringcreatewithutf8cstring send

113− return (o,s)

140+ return (o,s)

114− Just payload' -> do

141+ Just payload' -> do

115− d <- stringToJSValue c payload'

142+ d <- stringToJSValue c payload'

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

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

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

144+ s <- jsstringcreatewithutf8cstring send

118− return (o,s)

145+ return (o,s)

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

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

120− return ()

147+ takeMVar result >>= mapM_ throwIO

121−

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+

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

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

123xmlHttpRequestSetRequestHeader xhr header value = do

178xmlHttpRequestSetRequestHeader xhr header value = do

124 let c = xhrContext xhr

179 let c = xhrContext xhr

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

146 d <- jsvaluetonumber c s nullPtr

201 d <- jsvaluetonumber c s nullPtr

147 return $ truncate d

202 return $ truncate d

148

203

149−xmlHttpRequestGetStatusText :: XMLHttpRequest -> IO String

204+xmlHttpRequestGetStatusText :: XMLHttpRequest -> IO Text

150xmlHttpRequestGetStatusText xhr = do

205xmlHttpRequestGetStatusText xhr = do

151 let c = xhrContext xhr

206 let c = xhrContext xhr

152 script <- jsstringcreatewithutf8cstring "this.statusText"

207 script <- jsstringcreatewithutf8cstring "this.statusText"

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

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

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

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

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

158 peekCString ps

213 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 #-}

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

2−

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

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

4− , module Reflex.Dom.Internal.Foreign

3+ , runWebGUI

5 ) where

4 ) where

7import Control.Monad

6import Control.Monad

8import GHCJS.DOM

7import GHCJS.DOM

9import GHCJS.DOM.Types

8import GHCJS.DOM.Types

10import GHCJS.Types

9import GHCJS.Types

11−import Data.Function

12−import GHCJS.Foreign

13−

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

16−instance Eq Node where

11+quitWebView :: WebView -> IO ()

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

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

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

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

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

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

22getLocationHost _ = liftM fromJSString getLocationHost_

17getLocationHost _ = liftM fromJSString getLocationHost_

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

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

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

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

27getLocationProtocol _ = liftM fromJSString getLocationProtocol_

22getLocationProtocol _ = 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 #-}

3module Reflex.Dom.WebSocket.Foreign where

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

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

8import Data.ByteString (ByteString)

7import Data.ByteString (ByteString)

9−import Data.Text.Encoding

10import qualified Data.ByteString as BS

8import qualified Data.ByteString as BS

11−import Foreign.Ptr

12−import GHCJS.Foreign

13−import GHCJS.Marshal

14import GHCJS.Types

9import 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)

16import GHCJS.DOM.Types

14import 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

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

19−

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

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

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

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

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

35newWebSocket _ url onMessage onOpen onClose = do

24newWebSocket _ url onMessage onOpen onClose = do

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

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

37− rec onCloseFun <- syncCallback AlwaysRetain True $ do

26+ _ <- on ws open $ liftIO onOpen

38− release onMessageFun

27+ GD.setBinaryType ws "arraybuffer"

39− release onCloseFun

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

40− onClose

33+ _ <- on ws closeEvent $ liftIO onClose

41− onOpenFun <- syncCallback AlwaysRetain True $ do

34+ return $ JSWebSocket ws

42− release onOpenFun

35+

43− onOpen

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

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

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

9+import Prelude hiding (error)

6−import GHCJS.Foreign

7−import GHCJS.Marshal

8−import qualified Data.Text as T

9import Data.Text (Text)

10import Data.Text (Text)

10import GHCJS.DOM.Types hiding (Text)

11import GHCJS.DOM.Types hiding (Text)

11import GHCJS.DOM.EventM

12import GHCJS.DOM.EventM

12import GHCJS.DOM

13import GHCJS.DOM

13−import Data.Function

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

14−import Control.Monad

21+import Control.Exception (catch, throwIO)

22+

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

16prepareWebView :: WebView -> IO ()

25prepareWebView :: WebView -> IO ()

17prepareWebView _ = return ()

26prepareWebView _ = return ()

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

28+xmlHttpRequestNew :: a -> IO XMLHttpRequest

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

29+xmlHttpRequestNew _ = newXMLHttpRequest

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

31+xmlHttpRequestOpen ::

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

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

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

34+xmlHttpRequestOpen = open

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

36+convertException :: XHRError -> XhrException

26− -> (obj -> obj')

37+convertException e = case e of

27−castTo gtype objTypeName obj =

38+ XHRError -> XhrException_Error

28− case toGObject obj of

39+ XHRAborted -> XhrException_Aborted

29− gobj@(GObject objRef)

30− | typeInstanceIsA objRef gtype

31− -> unsafeCastGObject gobj

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

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

41+class IsXhrPayload a where

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

36−instance Eq XMLHttpRequest where

44+instance IsXhrPayload () where

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

45+ sendXhrPayload xhr _ = send xhr

39−instance ToJSRef XMLHttpRequest where

47+instance IsXhrPayload String where

40− toJSRef = return . unXMLHttpRequest

48+ sendXhrPayload = sendString

41− {-# INLINE toJSRef #-}

43−instance FromJSRef XMLHttpRequest where

50+instance IsXhrPayload FormData where

44− fromJSRef = return . fmap XMLHttpRequest . maybeJSNull

51+ sendXhrPayload = sendFormData

45− {-# INLINE fromJSRef #-}

47−class GObjectClass o => IsXMLHttpRequest o

53+instance IsXhrPayload Document where

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

54+ sendXhrPayload = sendDocument

49−toXMLHttpRequest = unsafeCastGObject . toGObject

51−instance IsXMLHttpRequest XMLHttpRequest

56+instance IsXhrPayload Blob where

52−instance GObjectClass XMLHttpRequest where

57+ sendXhrPayload = sendBlob

53− toGObject = GObject . castRef . unXMLHttpRequest

54− unsafeCastGObject = XMLHttpRequest . castRef . unGObject

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

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

57−castToXMLHttpRequest = castTo gTypeXMLHttpRequest "XMLHttpRequest"

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

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

60−gTypeXMLHttpRequest :: GType

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

61−gTypeXMLHttpRequest = GType gTypeXMLHttpRequest'

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

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

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

67+xmlHttpRequestSetRequestHeader = setRequestHeader

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

69+xmlHttpRequestAbort :: XMLHttpRequest -> IO ()

70+xmlHttpRequestAbort = abort

66−instance Eq XMLHttpRequestUpload where

72+xmlHttpRequestGetAllResponseHeaders :: XMLHttpRequest -> IO Text

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

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

69−instance ToJSRef XMLHttpRequestUpload where

75+xmlHttpRequestGetResponseHeader :: (ToJSString header)

70− toJSRef = return . unXMLHttpRequestUpload

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

71− {-# INLINE toJSRef #-}

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

73−instance FromJSRef XMLHttpRequestUpload where

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

74− fromJSRef = return . fmap XMLHttpRequestUpload . maybeJSNull

80+xmlHttpRequestOverrideMimeType = overrideMimeType

75− {-# INLINE fromJSRef #-}

77−class GObjectClass o => IsXMLHttpRequestUpload o

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

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

83+xmlHttpRequestDispatchEvent = dispatchEvent

79−toXMLHttpRequestUpload = unsafeCastGObject . toGObject

81−instance IsXMLHttpRequestUpload XMLHttpRequestUpload

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

82−instance GObjectClass XMLHttpRequestUpload where

86+xmlHttpRequestOnabort = (`on` abortEvent)

83− toGObject = GObject . castRef . unXMLHttpRequestUpload

84− unsafeCastGObject = XMLHttpRequestUpload . castRef . unGObject

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

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

87−castToXMLHttpRequestUpload = castTo gTypeXMLHttpRequestUpload "XMLHttpRequestUpload"

89+xmlHttpRequestOnerror = (`on` error)

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

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

90−gTypeXMLHttpRequestUpload :: GType

92+xmlHttpRequestOnload = (`on` load)

91−gTypeXMLHttpRequestUpload = GType gTypeXMLHttpRequestUpload'

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

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

94− ghcjs_dom_xml_http_request_new ::

95+xmlHttpRequestOnloadend = (`on` loadEnd)

95− IO (JSRef XMLHttpRequest)

97−xmlHttpRequestNew :: a -> IO XMLHttpRequest

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

98−xmlHttpRequestNew _ = XMLHttpRequest <$> ghcjs_dom_xml_http_request_new

98+xmlHttpRequestOnloadstart = (`on` loadStart)

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

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

101− ghcjs_dom_xml_http_request_open ::

101+xmlHttpRequestOnprogress = (`on` progress)

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

103

102

104−xmlHttpRequestOpen ::

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

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

104+xmlHttpRequestOntimeout = (`on` timeout)

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 }

121

105

122−class IsXhrPayload a where

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

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

107+xmlHttpRequestOnreadystatechange = (`on` readyStateChange)

124

108

125−instance IsXhrPayload () where

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

126− xmlHttpRequestSend xhr _ = xmlHttpRequestSendPayload xhr $ XhrPayload jsNull

110+xmlHttpRequestSetTimeout = setTimeout

127

111

128−instance IsXhrPayload String where

112+xmlHttpRequestGetTimeout :: XMLHttpRequest -> IO Word

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

113+xmlHttpRequestGetTimeout = getTimeout

130−

114+

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

115+xmlHttpRequestGetReadyState :: XMLHttpRequest -> IO Word

132−

116+xmlHttpRequestGetReadyState = getReadyState

133−instance IsXhrPayload File where

117+

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

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

135−

119+xmlHttpRequestSetWithCredentials = setWithCredentials

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

120+

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

121+xmlHttpRequestGetWithCredentials :: XMLHttpRequest -> IO Bool

138−

122+xmlHttpRequestGetWithCredentials = getWithCredentials

139−

123+

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

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

141− ghcjs_dom_xml_http_request_set_request_header ::

125+xmlHttpRequestGetUpload = getUpload

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

126+

143−

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

144−xmlHttpRequestSetRequestHeader ::

128+xmlHttpRequestGetResponseText = getResponseText

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

129+

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

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

147−xmlHttpRequestSetRequestHeader self header value

131+xmlHttpRequestGetResponseXML = getResponseXML

148− = ghcjs_dom_xml_http_request_set_request_header

132+

149− (unXMLHttpRequest (toXMLHttpRequest self))

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

150− (toJSString header)

134+xmlHttpRequestSetResponseType = setResponseType

151− (toJSString value)

135+

152−

136+toResponseType :: XhrResponseType -> XMLHttpRequestResponseType

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

137+toResponseType XhrResponseType_Default = XMLHttpRequestResponseType

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

138+toResponseType XhrResponseType_ArrayBuffer = XMLHttpRequestResponseTypeArraybuffer

155−

139+toResponseType XhrResponseType_Blob = XMLHttpRequestResponseTypeBlob

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

140+toResponseType XhrResponseType_Document = XMLHttpRequestResponseTypeDocument

157−xmlHttpRequestAbort self

141+toResponseType XhrResponseType_JSON = XMLHttpRequestResponseTypeJson

158− = ghcjs_dom_xml_http_request_abort

142+toResponseType XhrResponseType_Text = XMLHttpRequestResponseTypeText

159− (unXMLHttpRequest (toXMLHttpRequest self))

143+

160−

144+xmlHttpRequestGetResponseType :: XMLHttpRequest -> IO XMLHttpRequestResponseType

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

145+xmlHttpRequestGetResponseType = getResponseType

162− ghcjs_dom_xml_http_request_get_all_response_headers ::

146+

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 ::

147+xmlHttpRequestGetStatus :: XMLHttpRequest -> IO Word

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

381−xmlHttpRequestGetStatus self

148+xmlHttpRequestGetStatus = getStatus

382− = ghcjs_dom_xml_http_request_get_status

149+

383− (unXMLHttpRequest (toXMLHttpRequest self))

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

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 ::

151+xmlHttpRequestGetStatusText = getStatusText

152+

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

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

391−xmlHttpRequestGetStatusText self

154+xmlHttpRequestGetResponseURL = getResponseURL

392− = fromJSString <$>

155+

393− (ghcjs_dom_xml_http_request_get_status_text

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

394− (unXMLHttpRequest (toXMLHttpRequest self)))

157+xmlHttpRequestGetResponse xhr = do

395−

158+ mr <- getResponse xhr

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

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

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

406

160

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

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

11#ifdef __GHCJS__

12import qualified GHCJS.Marshal as JS

13+import qualified GHCJS.Marshal.Pure as JS

13import qualified GHCJS.Foreign as JS

14import qualified GHCJS.Foreign as JS

15+import qualified GHCJS.Foreign.Callback as JS

14import qualified GHCJS.Types as JS

16import qualified GHCJS.Types as JS

17+import qualified GHCJS.Buffer as JS

15import GHCJS.DOM

18import 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+

17import Data.Word

29import Data.Word

18import Foreign.Ptr

30import Foreign.Ptr

19import Foreign.C.Types

31import Foreign.C.Types

20import Data.Hashable

32import Data.Hashable

33+import Text.Encoding.Z

21#else

34#else

22import System.Glib.FFI

35import System.Glib.FFI

23import Graphics.UI.Gtk.WebKit.WebView

36import Graphics.UI.Gtk.WebKit.WebView

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

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

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

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

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

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

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

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

31#endif

43#endif

33import Control.Monad

45import Control.Monad

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

42import qualified Data.ByteString as BS

54import qualified Data.ByteString as BS

43import Control.Concurrent

55import Control.Concurrent

44import Data.Coerce

56import Data.Coerce

45−import Text.Encoding.Z

46import Data.Monoid

57import Data.Monoid

48class Monad m => HasWebView m where

59class Monad m => HasWebView m where

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

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

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

79#ifdef __GHCJS__

90#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

81newtype JSFFI = JSFFI JSFFI_Internal

92newtype JSFFI = JSFFI JSFFI_Internal

82#else

93#else

83newtype JSFFI = JSFFI String

94newtype JSFFI = JSFFI String

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

131data JSCtx_IO

142data JSCtx_IO

132

143

133instance IsJSContext JSCtx_IO where

144instance 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 }

135

146

136instance MonadJS JSCtx_IO IO where

147instance 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)

138 forkJS = forkIO

149 forkJS = forkIO

139 mkJSUndefined = return $ JSRef_IO JS.jsUndefined

150 mkJSUndefined = return $ JSRef_IO JS.jsUndefined

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

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

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

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

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

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

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

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

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

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

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

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

146 fromJSNumber (JSRef_IO r) = do

157 fromJSNumber (JSRef_IO r) = do

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

158+ Just n <- JS.fromJSVal r

148 return n

159 return n

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

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

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

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

151 withJSNumber n f = do

162 withJSNumber n f = do

152− r <- JS.toJSRef n

163+ r <- JS.toJSVal n

153− f $ JSRef_IO $ JS.castRef r

164+ f $ JSRef_IO r

154 withJSArray l f = do

165 withJSArray l f = do

155− r <- JS.toArray $ coerce l

166+ r <- JS.fromListIO $ coerce l

156− f $ JSRef_IO $ JS.castRef r

167+ f $ JSRef_IO $ coerce r

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

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

158 ba <- extractByteArray cStr $ BS.length payload

169 ba <- extractByteArray cStr $ BS.length payload

159 f $ JSUint8Array $ JSRef_IO ba

170 f $ JSUint8Array $ JSRef_IO ba

160 mkJSFun f = do

171 mkJSFun f = do

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

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

162− l <- JS.fromArray args

173+ l <- JS.toListIO $ coerce args

163 JSRef_IO result <- f $ coerce l

174 JSRef_IO result <- f $ coerce l

164− return $ JS.castRef result

175+ return result

165− liftM (JSFun . JSRef_IO) $ funWithArguments cb

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

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

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

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

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

168 getJSProp s (JSRef_IO o) = do

179 getJSProp s (JSRef_IO o) = do

169− r <- JS.getProp s o

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

170 return $ JSRef_IO r

181 return $ JSRef_IO r

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

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

172

183

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

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

174

185

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

176

187

177#else

188#else

178

189

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

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

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

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

21import GHCJS.DOM.Types hiding (Event)

22−import GHCJS.DOM (WebView)

22+--import GHCJS.DOM (WebView)

23−import Control.Monad.Exception

25-- | Alias for Data.Map.singleton

24-- | Alias for Data.Map.singleton

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

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

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

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

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

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

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

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

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

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

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

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

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

87runFrameWithTriggerRef r a = do

86runFrameWithTriggerRef r a = do

88 postGui <- askPostGui

87 postGui <- askPostGui

89 runWithActions <- askRunWithActions

88 runWithActions <- askRunWithActions

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

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

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

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

93 askPostGui = lift askPostGui

92 askPostGui = lift askPostGui

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

143 addVoidAction $ ffor e $ \o -> do

142 addVoidAction $ ffor e $ \o -> do

144 postGui <- askPostGui

143 postGui <- askPostGui

145 runWithActions <- askRunWithActions

144 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

147 return eResult

146 return eResult

148

147

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

148getPostBuild :: 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_)

6import Reflex.Dom.Internal.Foreign

7import Reflex.Dom.Class

8−import Foreign.JavaScript.TH

10import GHCJS.DOM hiding (runWebGUI)

9import GHCJS.DOM hiding (runWebGUI)

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

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

12import GHCJS.DOM.Node

11import GHCJS.DOM.Node

13−import GHCJS.DOM.HTMLElement

12+import GHCJS.DOM.Element

14import GHCJS.DOM.Document

13import GHCJS.DOM.Document

15import Reflex.Class

14import Reflex.Class

16import Reflex.Host.Class

15import Reflex.Host.Class

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

38data GuiEnv t h x

37data GuiEnv t h x

39 = GuiEnv { _guiEnvDocument :: !HTMLDocument

38 = GuiEnv { _guiEnvDocument :: !HTMLDocument

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

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

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

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

42 , _guiEnvWebView :: !(WebViewSingleton x)

41 , _guiEnvWebView :: !(WebViewSingleton x)

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

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

44 }

43 }

46--TODO: Poorly named

45--TODO: Poorly named

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

110 askRunWithActions = Gui $ view guiEnvRunWithActions

109 askRunWithActions = Gui $ view guiEnvRunWithActions

111 scheduleFollowup r a = Gui $ do

110 scheduleFollowup r a = Gui $ do

112 followupEventsRef <- view guiEnvFollowupEvents

111 followupEventsRef <- view guiEnvFollowupEvents

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

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

114

113

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

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

116 askPostGui = lift askPostGui

115 askPostGui = lift askPostGui

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

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

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

175 getRunWidget = return runWidget

174 getRunWidget = return runWidget

176

175

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

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

178+ liftIO $ quitWebView wv

179+

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

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

178runWidget rootElement w = do

181runWidget rootElement w = do

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

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

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

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

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

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

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

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

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

194− Just body <- documentGetBody doc

197+ Just body <- getBody doc

195 attachWidget body webViewSing w

198 attachWidget body webViewSing w

196

199

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

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

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

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

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

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

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

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

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

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

202 attachWidget headElement webViewSing h

205 attachWidget headElement webViewSing h

203− Just body <- documentGetBody doc

206+ Just body <- getBody doc

204 attachWidget body webViewSing b

207 attachWidget body webViewSing b

205

208

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

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

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

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

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

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

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

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

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

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

211− Just body <- documentGetBody doc

214+ Just body <- getBody doc

212 attachWidget body webViewSing w

215 attachWidget body webViewSing w

213

216

214instance HasPostGui t h m => HasPostGui t (WithWebView x h) (WithWebView x m) where

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

252

255

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

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

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

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

256 frames <- liftIO newChan

259 frames <- liftIO newChan

257 followupEvents <- liftIO $ newIORef []

260 followupEvents <- liftIO $ newIORef []

258 rec let guiEnv = GuiEnv doc (writeChan frames . runSpiderHost . flip runWithWebView wv) runWithActions wv followupEvents :: GuiEnv Spider (WithWebView x SpiderHost) x

261 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

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

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

274 let fe'' = catMaybes fe'

277 let fe'' = catMaybes fe'

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

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

276− Just df <- liftIO $ documentCreateDocumentFragment doc

279+ Just df <- liftIO $ createDocumentFragment doc

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

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

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

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

279 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

282 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

280 return (r, va)

283 return (r, va)

281− liftIO $ htmlElementSetInnerHTML rootElement ""

284+ setInnerHTML rootElement $ Just ""

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

285+ _ <- appendChild rootElement $ Just df

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

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

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

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

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

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

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

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

166inhomogeneousPoisson rnd rate maxRate t0 =

167 inhomogeneousPoissonFrom rnd rate maxRate t0 =<< getPostBuild

168

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

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

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

172debounce dt e = do

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

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

44 let onMessage :: ByteString -> IO ()

45 onMessage m = postGui $ do

46 mt <- readRef eRecvTriggerRef

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

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

48 onOpen = postGui $ do

49 mt <- readRef eOpenTriggerRef

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

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

51 start = do

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

53 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

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

22import GHCJS.DOM.Node

23import GHCJS.DOM.UIEvent

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

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

25import GHCJS.DOM.Document

26−import GHCJS.DOM.Element

26+import GHCJS.DOM.Element as E

27−import GHCJS.DOM.HTMLElement

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

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

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

29−import GHCJS.DOM.NamedNodeMap

29+import GHCJS.DOM.NamedNodeMap as NNM

30import Control.Lens hiding (element, children)

31import Data.These

32import Data.Align

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

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

62instance MonadIO m => Attributes m AttributeMap where

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

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

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

66 addAttributes attrs e = do

67 schedulePostBuild $ do

68 curAttrs <- sample $ current attrs

69− liftIO $ imapM_ (elementSetAttribute e) curAttrs

69+ imapM_ (setAttribute e) curAttrs

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

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

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

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

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

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

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

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

76buildEmptyElementNS mns elementTag attrs = do

77 doc <- askDocument

78 p <- askParent

79 Just e <- liftIO $ case mns of

80− Nothing -> documentCreateElement doc elementTag

80+ Nothing -> createElement doc (Just elementTag)

81− Just ns -> documentCreateElementNS doc ns elementTag

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

82 addAttributes attrs e

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

83+ _ <- appendChild p $ Just e

84 return $ castToElement e

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

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

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

97buildElement = buildElementNS Nothing

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

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

100namedNodeMapGetNames self = do

101− l <- namedNodeMapGetLength self

101+ l <- NNM.getLength self

102 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

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

104− Just n <- namedNodeMapItem self i

104+ Just n <- NNM.item self i

105− nodeGetNodeName n

105+ getNodeName n

106

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

108text = void . text'

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

112text' s = do

113 doc <- askDocument

114 p <- askParent

115− Just n <- liftIO $ documentCreateTextNode doc s

115+ Just n <- createTextNode doc s

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

116+ _ <- appendChild p $ Just n

117 return n

118

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

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

121 n <- text' ""

122 schedulePostBuild $ do

123 curS <- sample $ current s

124− liftIO $ nodeSetNodeValue n curS

124+ setNodeValue n $ Just curS

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

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

126

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

128display a = dynText =<< mapDyn show a

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

159 doc <- askDocument

160 runWidget <- getRunWidget

161 let build c = do

162− Just df <- liftIO $ documentCreateDocumentFragment doc

162+ Just df <- createDocumentFragment doc

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

164 scheduleFollowup newChildBuiltTriggerRef (result, voidActions)

165 postBuild

166− mp' <- liftIO $ nodeGetParentNode endPlaceholder

166+ mp' <- getParentNode endPlaceholder

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

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

168 return ()

169 addVoidAction $ ffor newChild $ \c -> do

170 liftIO $ deleteBetweenExclusive startPlaceholder endPlaceholder

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

209 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

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

211 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

213

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

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

224 result <- mkChild k v

225 childEnd <- text' ""

226 return (result, (childStart, childEnd))

227− Just dfOrig <- liftIO $ documentCreateDocumentFragment doc

227+ Just dfOrig <- createDocumentFragment doc

228 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

229 stateRef <- liftIO $ newIORef initialState

230 children <- holdDyn initialState newChildren

231 tellWidgetOutput =<< mapDyn (fmap snd) children

232− mpOrig <- liftIO $ nodeGetParentNode endPlaceholder

232+ mpOrig <- getParentNode endPlaceholder

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

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

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

235 curState <- liftIO $ readIORef stateRef

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

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

240 return Nothing

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

242 liftIO $ deleteBetweenExclusive start end

243− Just df <- liftIO $ documentCreateDocumentFragment doc

243+ Just df <- createDocumentFragment doc

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

245 let s = (childResult, childVoidAction)

246 modify (>>childPostBuild)

247− mp <- liftIO $ nodeGetParentNode end

247+ mp <- getParentNode end

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

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

249 return $ Just s

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

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

252− Just df <- liftIO $ documentCreateDocumentFragment doc

252+ Just df <- createDocumentFragment doc

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

254 let s = (childResult, childVoidAction)

255 modify (>>childPostBuild)

256 let placeholder = case Map.lookupGT k curState of

257 Nothing -> endPlaceholder

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

259− mp <- liftIO $ nodeGetParentNode placeholder

259+ mp <- getParentNode placeholder

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

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

261 return $ Just s

262 This state -> do -- No change

263 return $ Just state

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

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

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

305deleteBetweenExclusive 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

307 case mCurrentParent of

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

309 Just currentParent -> do

310 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

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

313− _ <- nodeRemoveChild currentParent $ Just x

313+ _ <- removeChild currentParent $ Just x

314 go

315 go

316

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

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

319deleteBetweenInclusive 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

321 case mCurrentParent of

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

323 Just currentParent -> do

324 let go = do

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

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

326− _ <- nodeRemoveChild currentParent $ Just x

326+ _ <- removeChild currentParent $ Just x

327 when (toNode s /= toNode x) go

328 go

329− _ <- nodeRemoveChild currentParent $ Just e

329+ _ <- removeChild currentParent $ Just e

330 return ()

331

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+

332--------------------------------------------------------------------------------

341--------------------------------------------------------------------------------

333-- Adapters

342-- Adapters

334--------------------------------------------------------------------------------

343--------------------------------------------------------------------------------

335

344

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)

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

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

338

347

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)

340wrapDomEventMaybe element elementOnevent getValue = do

349wrapDomEventMaybe element elementOnevent getValue = do

341 postGui <- askPostGui

350 postGui <- askPostGui

342 runWithActions <- askRunWithActions

351 runWithActions <- askRunWithActions

343 e <- newEventWithTrigger $ \et -> do

352 e <- newEventWithTrigger $ \et -> do

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

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

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

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

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

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

347 return $ liftIO $ do

356 return $ liftIO $ do

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

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

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

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

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

377 | MouseoutTag

386 | MouseoutTag

378 | MouseoverTag

387 | MouseoverTag

379 | MouseupTag

388 | 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

381 | ScrollTag

390 | ScrollTag

382 | SelectTag

391 | SelectTag

383 | SubmitTag

392 | SubmitTag

384−-- | WheelTag -- See MousewheelTag

393+ | WheelTag

385 | BeforecutTag

394 | BeforecutTag

386 | CutTag

395 | CutTag

387 | BeforecopyTag

396 | BeforecopyTag

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

425 Mouseout :: EventName 'MouseoutTag

434 Mouseout :: EventName 'MouseoutTag

426 Mouseover :: EventName 'MouseoverTag

435 Mouseover :: EventName 'MouseoverTag

427 Mouseup :: EventName 'MouseupTag

436 Mouseup :: EventName 'MouseupTag

428− --Mousewheel :: EventName 'MousewheelTag

437+ Mousewheel :: EventName 'MousewheelTag

429 Scroll :: EventName 'ScrollTag

438 Scroll :: EventName 'ScrollTag

430 Select :: EventName 'SelectTag

439 Select :: EventName 'SelectTag

431 Submit :: EventName 'SubmitTag

440 Submit :: EventName 'SubmitTag

432− --Wheel :: EventName 'WheelTag

441+ Wheel :: EventName 'WheelTag

433 Beforecut :: EventName 'BeforecutTag

442 Beforecut :: EventName 'BeforecutTag

434 Cut :: EventName 'CutTag

443 Cut :: EventName 'CutTag

435 Beforecopy :: EventName 'BeforecopyTag

444 Beforecopy :: EventName 'BeforecopyTag

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

446

455

447type family EventType en where

456type family EventType en where

448 EventType 'AbortTag = UIEvent

457 EventType 'AbortTag = UIEvent

449− EventType 'BlurTag = UIEvent

458+ EventType 'BlurTag = FocusEvent

450− EventType 'ChangeTag = UIEvent

459+ EventType 'ChangeTag = DOM.Event

451 EventType 'ClickTag = MouseEvent

460 EventType 'ClickTag = MouseEvent

452 EventType 'ContextmenuTag = MouseEvent

461 EventType 'ContextmenuTag = MouseEvent

453 EventType 'DblclickTag = MouseEvent

462 EventType 'DblclickTag = MouseEvent

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

459 EventType 'DragstartTag = MouseEvent

468 EventType 'DragstartTag = MouseEvent

460 EventType 'DropTag = MouseEvent

469 EventType 'DropTag = MouseEvent

461 EventType 'ErrorTag = UIEvent

470 EventType 'ErrorTag = UIEvent

462− EventType 'FocusTag = UIEvent

471+ EventType 'FocusTag = FocusEvent

463− EventType 'InputTag = UIEvent

472+ EventType 'InputTag = DOM.Event

464− EventType 'InvalidTag = UIEvent

473+ EventType 'InvalidTag = DOM.Event

465− EventType 'KeydownTag = UIEvent

474+ EventType 'KeydownTag = KeyboardEvent

466− EventType 'KeypressTag = UIEvent

475+ EventType 'KeypressTag = KeyboardEvent

467− EventType 'KeyupTag = UIEvent

476+ EventType 'KeyupTag = KeyboardEvent

468 EventType 'LoadTag = UIEvent

477 EventType 'LoadTag = UIEvent

469 EventType 'MousedownTag = MouseEvent

478 EventType 'MousedownTag = MouseEvent

470− EventType 'MouseenterTag = UIEvent

479+ EventType 'MouseenterTag = MouseEvent

471− EventType 'MouseleaveTag = UIEvent

480+ EventType 'MouseleaveTag = MouseEvent

472 EventType 'MousemoveTag = MouseEvent

481 EventType 'MousemoveTag = MouseEvent

473 EventType 'MouseoutTag = MouseEvent

482 EventType 'MouseoutTag = MouseEvent

474 EventType 'MouseoverTag = MouseEvent

483 EventType 'MouseoverTag = MouseEvent

475 EventType 'MouseupTag = MouseEvent

484 EventType 'MouseupTag = MouseEvent

476− --EventType 'MousewheelTag = MouseEvent

485+ EventType 'MousewheelTag = MouseEvent

477 EventType 'ScrollTag = UIEvent

486 EventType 'ScrollTag = UIEvent

478 EventType 'SelectTag = UIEvent

487 EventType 'SelectTag = UIEvent

479− EventType 'SubmitTag = UIEvent

488+ EventType 'SubmitTag = DOM.Event

480− --EventType 'WheelTag = UIEvent

489+ EventType 'WheelTag = WheelEvent

481− EventType 'BeforecutTag = UIEvent

490+ EventType 'BeforecutTag = DOM.Event

482− EventType 'CutTag = UIEvent

491+ EventType 'CutTag = DOM.Event

483− EventType 'BeforecopyTag = UIEvent

492+ EventType 'BeforecopyTag = DOM.Event

484− EventType 'CopyTag = UIEvent

493+ EventType 'CopyTag = DOM.Event

485− EventType 'BeforepasteTag = UIEvent

494+ EventType 'BeforepasteTag = DOM.Event

486− EventType 'PasteTag = UIEvent

495+ EventType 'PasteTag = DOM.Event

487− EventType 'ResetTag = UIEvent

496+ EventType 'ResetTag = DOM.Event

488− EventType 'SearchTag = UIEvent

497+ EventType 'SearchTag = DOM.Event

489− EventType 'SelectstartTag = UIEvent

498+ EventType 'SelectstartTag = DOM.Event

490− EventType 'TouchstartTag = UIEvent

499+ EventType 'TouchstartTag = TouchEvent

491− EventType 'TouchmoveTag = UIEvent

500+ EventType 'TouchmoveTag = TouchEvent

492− EventType 'TouchendTag = UIEvent

501+ EventType 'TouchendTag = TouchEvent

493− EventType 'TouchcancelTag = UIEvent

502+ EventType 'TouchcancelTag = TouchEvent

494−

503+

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

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

496−onEventName en = case en of

505+onEventName en e = case en of

497− Abort -> elementOnabort

506+ Abort -> on e E.abort

498− Blur -> elementOnblur

507+ Blur -> on e E.blurEvent

499− Change -> elementOnchange

508+ Change -> on e E.change

500− Click -> elementOnclick

509+ Click -> on e E.click

501− Contextmenu -> elementOncontextmenu

510+ Contextmenu -> on e E.contextMenu

502− Dblclick -> elementOndblclick

511+ Dblclick -> on e E.dblClick

503− Drag -> elementOndrag

512+ Drag -> on e E.drag

504− Dragend -> elementOndragend

513+ Dragend -> on e E.dragEnd

505− Dragenter -> elementOndragenter

514+ Dragenter -> on e E.dragEnter

506− Dragleave -> elementOndragleave

515+ Dragleave -> on e E.dragLeave

507− Dragover -> elementOndragover

516+ Dragover -> on e E.dragOver

508− Dragstart -> elementOndragstart

517+ Dragstart -> on e E.dragStart

509− Drop -> elementOndrop

518+ Drop -> on e E.drop

510− Error -> elementOnerror

519+ Error -> on e E.error

511− Focus -> elementOnfocus

520+ Focus -> on e E.focusEvent

512− Input -> elementOninput

521+ Input -> on e E.input

513− Invalid -> elementOninvalid

522+ Invalid -> on e E.invalid

514− Keydown -> elementOnkeydown

523+ Keydown -> on e E.keyDown

515− Keypress -> elementOnkeypress

524+ Keypress -> on e E.keyPress

516− Keyup -> elementOnkeyup

525+ Keyup -> on e E.keyUp

517− Load -> elementOnload

526+ Load -> on e E.load

518− Mousedown -> elementOnmousedown

527+ Mousedown -> on e E.mouseDown

519− Mouseenter -> elementOnmouseenter

528+ Mouseenter -> on e E.mouseEnter

520− Mouseleave -> elementOnmouseleave

529+ Mouseleave -> on e E.mouseLeave

521− Mousemove -> elementOnmousemove

530+ Mousemove -> on e E.mouseMove

522− Mouseout -> elementOnmouseout

531+ Mouseout -> on e E.mouseOut

523− Mouseover -> elementOnmouseover

532+ Mouseover -> on e E.mouseOver

524− Mouseup -> elementOnmouseup

533+ Mouseup -> on e E.mouseUp

525− --Mousewheel -> elementOnmousewheel

534+ Mousewheel -> on e E.mouseWheel

526− Scroll -> elementOnscroll

535+ Scroll -> on e E.scroll

527− Select -> elementOnselect

536+ Select -> on e E.select

528− Submit -> elementOnsubmit

537+ Submit -> on e E.submit

529− --Wheel -> elementOnwheel

538+ Wheel -> on e E.wheel

530− Beforecut -> elementOnbeforecut

539+ Beforecut -> on e E.beforeCut

531− Cut -> elementOncut

540+ Cut -> on e E.cut

532− Beforecopy -> elementOnbeforecopy

541+ Beforecopy -> on e E.beforeCopy

533− Copy -> elementOncopy

542+ Copy -> on e E.copy

534− Beforepaste -> elementOnbeforepaste

543+ Beforepaste -> on e E.beforePaste

535− Paste -> elementOnpaste

544+ Paste -> on e E.paste

536− Reset -> elementOnreset

545+ Reset -> on e E.reset

537− Search -> elementOnsearch

546+ Search -> on e E.search

538− Selectstart -> elementOnselectstart

547+ Selectstart -> on e E.selectStart

539− Touchstart -> elementOntouchstart

548+ Touchstart -> on e E.touchStart

540− Touchmove -> elementOntouchmove

549+ Touchmove -> on e E.touchMove

541− Touchend -> elementOntouchend

550+ Touchend -> on e E.touchEnd

542− Touchcancel -> elementOntouchcancel

551+ Touchcancel -> on e E.touchCancel

543

552

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

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

545

554

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

588 EventResultType 'TouchmoveTag = ()

597 EventResultType 'TouchmoveTag = ()

589 EventResultType 'TouchendTag = ()

598 EventResultType 'TouchendTag = ()

590 EventResultType 'TouchcancelTag = ()

599 EventResultType 'TouchcancelTag = ()

600+ EventResultType 'MousewheelTag = ()

601+ EventResultType 'WheelTag = ()

591

602

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

593wrapDomEventsMaybe element handlers = do

604wrapDomEventsMaybe element handlers = do

594 postGui <- askPostGui

605 postGui <- askPostGui

595 runWithActions <- askRunWithActions

606 runWithActions <- askRunWithActions

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

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

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

608+ unsubscribe <- onEventName en element $ do

598 mv <- handlers en

609 mv <- handlers en

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

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

600 return $ liftIO $ do

611 return $ liftIO $ do

601 unsubscribe

612 unsubscribe

602 return $! e

613 return $! e

603

614

604−getKeyEvent :: EventM UIEvent e Int

615+getKeyEvent :: EventM e KeyboardEvent Int

605getKeyEvent = do

616getKeyEvent = do

606 e <- event

617 e <- event

607− liftIO $ do

618+ which <- getWhich e

608− which <- uiEventGetWhich e

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

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

610− charCode <- uiEventGetCharCode e

620+ charCode <- getCharCode e

611− if charCode /= 0 then return charCode else

621+ if charCode /= 0 then return charCode else

612− uiEventGetKeyCode e

622+ getKeyCode e

613−

623+

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

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

615getMouseEventCoords = do

625getMouseEventCoords = do

616 e <- event

626 e <- event

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

627+ bisequence (getX e, getY e)

618

628

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

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

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

621 Click -> return ()

631 Click -> return ()

622 Dblclick -> return ()

632 Dblclick -> return ()

623 Keypress -> getKeyEvent

633 Keypress -> getKeyEvent

634+ Scroll -> getScrollTop e

624 Keydown -> getKeyEvent

635 Keydown -> getKeyEvent

625 Keyup -> getKeyEvent

636 Keyup -> getKeyEvent

626− Scroll -> liftIO $ elementGetScrollTop e

627 Mousemove -> getMouseEventCoords

637 Mousemove -> getMouseEventCoords

628 Mouseup -> getMouseEventCoords

638 Mouseup -> getMouseEventCoords

629 Mousedown -> getMouseEventCoords

639 Mousedown -> getMouseEventCoords

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

662 Touchmove -> return ()

672 Touchmove -> return ()

663 Touchend -> return ()

673 Touchend -> return ()

664 Touchcancel -> return ()

674 Touchcancel -> return ()

675+ Mousewheel -> return ()

676+ Wheel -> return ()

665

677

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)

667wrapElement eh e = do

679wrapElement eh e = do

668 es <- wrapDomEventsMaybe e $ eh e

680 es <- wrapDomEventsMaybe e $ eh e

669 return $ El e es

681 return $ El e es

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

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

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

749elDynHtml' elementTag html = do

761elDynHtml' elementTag html = do

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

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

751− let h = castToHTMLElement e

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

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

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

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

754 wrapElement defaultDomEventHandler e

765 wrapElement defaultDomEventHandler e

755

766

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

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

757elDynHtmlAttr' elementTag attrs html = do

768elDynHtmlAttr' elementTag attrs html = do

758 e <- buildEmptyElement elementTag attrs

769 e <- buildEmptyElement elementTag attrs

759− let h = castToHTMLElement e

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

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

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

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

762 wrapElement defaultDomEventHandler e

772 wrapElement defaultDomEventHandler e

763

773

764data Link t

774data Link t

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

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

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

784

794

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

795instance 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)

787

797

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

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

789linkClass s c = do

799linkClass s c = do

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

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

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

872unsafePlaceElement e = do

882unsafePlaceElement e = do

873 p <- askParent

883 p <- askParent

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

884+ _ <- appendChild p $ Just e

875 wrapElement defaultDomEventHandler e

885 wrapElement defaultDomEventHandler e

876

886

877deriveGEq ''EventName

887deriveGEq ''EventName

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

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

9import Reflex

10import Reflex.Host.Class

11−import GHCJS.DOM.HTMLInputElement

11+import GHCJS.DOM.HTMLInputElement as Input

12−import GHCJS.DOM.HTMLTextAreaElement

12+import GHCJS.DOM.HTMLTextAreaElement as TextArea

13−import GHCJS.DOM.Element

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

14−import GHCJS.DOM.HTMLSelectElement

14+import GHCJS.DOM.HTMLSelectElement as Select

15import GHCJS.DOM.EventM

16import GHCJS.DOM.File

17−import GHCJS.DOM.FileList

17+import qualified GHCJS.DOM.FileList as FileList

18import Data.Monoid

19import Data.Map as Map

20import Control.Lens

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

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

54textInput (TextInputConfig inputType initial eSetValue dAttrs) = do

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

56− liftIO $ htmlInputElementSetValue e initial

56+ Input.setValue e $ Just initial

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

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

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

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

59 postGui <- askPostGui

60 runWithActions <- askRunWithActions

61 eChangeFocus <- newEventWithTrigger $ \eChangeFocusTrigger -> do

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

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

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

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

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

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

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

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

66 return $ liftIO $ unsubscribeOnblur >> unsubscribeOnfocus

67 dFocus <- holdDyn False eChangeFocus

68− eKeypress <- wrapDomEvent e elementOnkeypress getKeyEvent

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

69− eKeydown <- wrapDomEvent e elementOnkeydown getKeyEvent

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

70− eKeyup <- wrapDomEvent e elementOnkeyup getKeyEvent

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

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

72 return $ TextInput dValue eChange eKeypress eKeydown eKeyup dFocus e

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

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

98textArea (TextAreaConfig initial eSet attrs) = do

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

100− liftIO $ htmlTextAreaElementSetValue e initial

100+ TextArea.setValue e $ Just initial

101 postGui <- askPostGui

102 runWithActions <- askRunWithActions

103 eChangeFocus <- newEventWithTrigger $ \eChangeFocusTrigger -> do

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

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

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

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

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

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

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

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

108 return $ liftIO $ unsubscribeOnblur >> unsubscribeOnfocus

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

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

110 f <- holdDyn False eChangeFocus

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

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

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

113− eKeypress <- wrapDomEvent e elementOnkeypress getKeyEvent

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

114 return $ TextArea v ev e f eKeypress

115

116data CheckboxConfig t

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

135checkbox checked config = do

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

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

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

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

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

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

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

141 return $ Checkbox dValue eClick

142

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

144checkboxView dAttrs dValue = do

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

146− eClicked <- wrapDomEvent e elementOnclick $ do

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

147 preventDefault

148− liftIO $ htmlInputElementGetChecked e

148+ Input.getChecked e

149 schedulePostBuild $ do

150 v <- sample $ current dValue

151− when v $ liftIO $ htmlInputElementSetChecked e True

151+ when v $ Input.setChecked e True

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

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

153 return eClicked

154

155data FileInput t

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

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

169fileInput (FileInputConfig dAttrs) = do

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

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

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

172− Just files <- htmlInputElementGetFiles e

172+ Just files <- getFiles e

173− len <- fileListGetLength files

173+ len <- FileList.getLength files

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

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

175 dValue <- holdDyn [] eChange

176 return $ FileInput dValue e

177

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

201 listWithKey optionsWithDefault $ \k v -> do

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

203 let e = castToHTMLSelectElement $ _el_element eRaw

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

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

205− eChange <- wrapDomEvent e elementOnchange $ do

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

206− kStr <- liftIO $ htmlSelectElementGetValue e

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

207 return $ readMay kStr

208 let readKey opts mk = fromMaybe k0 $ do

209 k <- mk

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

326instance HasStateModeWitness View where

327 stateModeWitness = ViewWitness

328-}

329−

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

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

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

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

51 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]

53 indexAndLength <- mapDyn snd window

54 return (indexAndLength, sel)

55 where

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

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

93 ]

94 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]

96 return (nubDyn window, result)

97 where

98 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

8import Control.Monad

9import Control.Monad.IO.Class

10import Data.Monoid

11−import GHCJS.DOM.Element

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

12+import GHCJS.DOM.EventM (on)

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

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

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

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

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

31 let reset = do

32 let reset = do

32 let e = _el_element expand

33 let e = _el_element expand

33 s = _el_element shrink

34 s = _el_element shrink

34− eow <- elementGetOffsetWidth e

35+ eow <- getOffsetWidth e

35− eoh <- elementGetOffsetHeight e

36+ eoh <- getOffsetHeight e

36 let ecw = eow + 10

37 let ecw = eow + 10

37 ech = eoh + 10

38 ech = eoh + 10

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

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

39− esw <- elementGetScrollWidth e

40+ esw <- getScrollWidth e

40− elementSetScrollLeft e esw

41+ setScrollLeft e esw

41− esh <- elementGetScrollHeight e

42+ esh <- getScrollHeight e

42− elementSetScrollTop e esh

43+ setScrollTop e esh

43− ssw <- elementGetScrollWidth s

44+ ssw <- getScrollWidth s

44− elementSetScrollLeft s ssw

45+ setScrollLeft s ssw

45− ssh <- elementGetScrollHeight s

46+ ssh <- getScrollHeight s

46− elementSetScrollTop s ssh

47+ setScrollTop s ssh

47− lastWidth <- elementGetOffsetWidth (_el_element parent)

48+ lastWidth <- getOffsetWidth (_el_element parent)

48− lastHeight <- elementGetOffsetHeight (_el_element parent)

49+ lastHeight <- getOffsetHeight (_el_element parent)

49 return (Just lastWidth, Just lastHeight)

50 return (Just lastWidth, Just lastHeight)

50 resetIfChanged ds = do

51 resetIfChanged ds = do

51− pow <- elementGetOffsetWidth (_el_element parent)

52+ pow <- getOffsetWidth (_el_element parent)

52− poh <- elementGetOffsetHeight (_el_element parent)

53+ poh <- getOffsetHeight (_el_element parent)

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

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

54 then return Nothing

55 then return Nothing

55 else liftM Just reset

56 else liftM Just reset

56 pb <- getPostBuild

57 pb <- getPostBuild

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

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

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

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

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

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

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

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

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

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

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

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

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

2module Reflex.Dom.Xhr

3− ( module Reflex.Dom.Xhr

4− , XMLHttpRequest

3+ ( XMLHttpRequest

5− , responseTextToText

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

6 , xmlHttpRequestGetReadyState

26 , xmlHttpRequestGetReadyState

7 , xmlHttpRequestGetResponseText

27 , xmlHttpRequestGetResponseText

8 , xmlHttpRequestGetStatus

28 , xmlHttpRequestGetStatus

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

13 , xmlHttpRequestSend

33 , xmlHttpRequestSend

14 , xmlHttpRequestSetRequestHeader

34 , xmlHttpRequestSetRequestHeader

15 , xmlHttpRequestSetResponseType

35 , 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

16 )

48 )

17where

49where

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

21import Reflex.Dom.Xhr.Foreign

53import Reflex.Dom.Xhr.Foreign

23import Control.Concurrent

55import Control.Concurrent

56+import Control.Exception (catch)

24import Control.Lens

57import Control.Lens

25import Control.Monad hiding (forM)

58import Control.Monad hiding (forM)

26import Control.Monad.IO.Class

59import Control.Monad.IO.Class

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

36import Data.Text (Text)

69import Data.Text (Text)

37import Data.Text.Encoding

70import Data.Text.Encoding

38import Data.Traversable

71import Data.Traversable

72+import Reflex.Dom.Xhr.Exception

73+import Reflex.Dom.Xhr.ResponseType

39import Data.Typeable

74import Data.Typeable

41data XhrRequest a

76data XhrRequest a

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

49 = XhrRequestConfig { _xhrRequestConfig_headers :: Map String String

84 = XhrRequestConfig { _xhrRequestConfig_headers :: Map String String

50 , _xhrRequestConfig_user :: Maybe String

85 , _xhrRequestConfig_user :: Maybe String

51 , _xhrRequestConfig_password :: Maybe String

86 , _xhrRequestConfig_password :: Maybe String

52− , _xhrRequestConfig_responseType :: Maybe String

87+ , _xhrRequestConfig_responseType :: Maybe XhrResponseType

53 , _xhrRequestConfig_sendData :: a

88 , _xhrRequestConfig_sendData :: a

54 }

89 }

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

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

57data XhrResponse

92data XhrResponse

58− = XhrResponse { _xhrResponse_body :: Maybe Text

59− , _xhrResponse_status :: Word

93+ = XhrResponse { _xhrResponse_status :: Word

60 , _xhrResponse_statusText :: Text

94 , _xhrResponse_statusText :: Text

95+ , _xhrResponse_response :: Maybe XhrResponseBody

96+ , _xhrResponse_responseText :: Maybe Text

61 }

97 }

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 })

107

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

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

65 def = XhrRequestConfig { _xhrRequestConfig_headers = Map.empty

109 def = XhrRequestConfig { _xhrRequestConfig_headers = Map.empty

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

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

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

74xhrRequest = XhrRequest

118xhrRequest = XhrRequest

119

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

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

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

77−newXMLHttpRequest req cb = do

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

78 wv <- askWebView

134 wv <- askWebView

79 postGui <- askPostGui

135 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

82 let c = _xhrRequest_config req

138 let c = _xhrRequest_config req

139+ rt = _xhrRequestConfig_responseType c

83 xmlHttpRequestOpen

140 xmlHttpRequestOpen

84 xhr

141 xhr

85 (_xhrRequest_method req)

142 (_xhrRequest_method req)

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

88 (fromMaybe "" $ _xhrRequestConfig_user c)

145 (fromMaybe "" $ _xhrRequestConfig_user c)

89 (fromMaybe "" $ _xhrRequestConfig_password c)

146 (fromMaybe "" $ _xhrRequestConfig_password c)

90 iforM_ (_xhrRequestConfig_headers c) $ xmlHttpRequestSetRequestHeader xhr

147 iforM_ (_xhrRequestConfig_headers c) $ xmlHttpRequestSetRequestHeader xhr

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

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

92 _ <- xmlHttpRequestOnreadystatechange xhr $ do

149 _ <- xmlHttpRequestOnreadystatechange xhr $ do

93 readyState <- liftIO $ xmlHttpRequestGetReadyState xhr

150 readyState <- liftIO $ xmlHttpRequestGetReadyState xhr

94 status <- liftIO $ xmlHttpRequestGetStatus xhr

151 status <- liftIO $ xmlHttpRequestGetStatus xhr

95 statusText <- liftIO $ xmlHttpRequestGetStatusText xhr

152 statusText <- liftIO $ xmlHttpRequestGetStatusText xhr

96 if readyState == 4

153 if readyState == 4

97 then do

154 then do

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

98− r <- liftIO $ xmlHttpRequestGetResponseText xhr

156+ then liftIO $ xmlHttpRequestGetResponseText xhr

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

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

100 return ()

165 return ()

101 else return ()

166 else return ()

102 _ <- xmlHttpRequestSend xhr (_xhrRequestConfig_sendData c)

167 _ <- 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

104

184

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

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

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

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

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)

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

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

195+ r <- hr

108− _ <- newXMLHttpRequest r $ liftIO . cb

196+ newXhr r $ liftIO . cb

109 return ()

197 return ()

110

198

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+

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

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

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

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

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

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

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

223+ rs <- hrs

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

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

115 resp <- liftIO newEmptyMVar

225 resp <- liftIO newEmptyMVar

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

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

117 return resp

227 return resp

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

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

119 return ()

229 return ()

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

126

236

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

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

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

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

129−postJson url a =

239+postJson url a =

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

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

131 , _xhrRequestConfig_sendData = body

241 , _xhrRequestConfig_sendData = body

132 }

242 }

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

143

253

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

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

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

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

146−decodeXhrResponse = join . fmap decodeText . _xhrResponse_body

256+decodeXhrResponse = join . fmap decodeText . _xhrResponse_responseText

147

257

148liftM concat $ mapM makeLenses

258liftM concat $ mapM makeLenses

149 [ ''XhrRequest

259 [ ''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 ()