172a48c · reflex-dom · git.iko.soy

git.iko.soy/reflex-dom

on develop help sign in

Merge develop into dynamic-writer

172a48cCale Gibbard11 years ago

README.md+9−5

compare with develop

unifiedsplit

@@ -1,13 +1,17 @@

1## Reflex-DOM

2### A Framework for Functional Reactive Web Apps in Haskell

4−Reflex-DOM is a framework for building web applications in Haskell, based on the [Functional Reactive Programming](https://wiki.haskell.org/Functional_Reactive_Programming) library [Reflex](https://github.com/ryantrinkle/reflex).

4+Reflex-DOM is a framework for building web applications in Haskell, based on the [Functional Reactive Programming](https://wiki.haskell.org/Functional_Reactive_Programming) library [Reflex](https://github.com/reflex-frp/reflex).

6−Comprehensive documentation is still a work in progress, but a [demo](https://github.com/ryantrinkle/try-reflex) is available and an introductory talk is available at [Part 1](https://www.youtube.com/watch?v=mYvkcskJbc4) / [Part 2](https://www.youtube.com/watch?v=3qfc9XFVo2c) ([Slides](https://obsidian.systems/reflex-nyhug/)).

6+Comprehensive documentation is still a work in progress, but a [demo](https://github.com/reflex-frp/reflex-platform) is available and an introductory talk is available at [Part 1](https://www.youtube.com/watch?v=mYvkcskJbc4) / [Part 2](https://www.youtube.com/watch?v=3qfc9XFVo2c) ([Slides](https://obsidian.systems/reflex-nyhug/)).

8+A summary of Reflex-DOM functions is available in the [quick reference](Quickref.md).

8### Additional resources

10### Additional resources

9−[try reflex](https://github.com/ryantrinkle/try-reflex)

11+[Get started with Reflex](https://github.com/reflex-frp/reflex-platform)

12+

13+[/r/reflexfrp](https://www.reddit.com/r/reflexfrp)

11−[reddit/r/reflexfrp](http://www.reddit.com/r/reflexfrp)

15+[hackage](https://hackage.haskell.org/package/reflex)

13−irc.freenode.net #reflex-frp

17+[irc.freenode.net #reflex-frp](http://webchat.freenode.net?channels=%23reflex-frp&uio=d4)

default.nix+5−5

@@ -1,13 +1,13 @@

1{ mkDerivation, pkgs, dependent-map, ghcjs-dom, lens

2−, mtl, ref-tf, reflex, safe, text, these

2+, mtl, ref-tf, reflex, text, these

3, transformers, data-default, semigroups, aeson

4, ghc, webkitgtk3-javascriptcore, exception-transformers

5−, dependent-sum-template, bifunctors

5+, dependent-sum-template, bifunctors, bimap, raw-strings-qq

6}:

8mkDerivation {

9 pname = "reflex-dom";

10− version = "0.2";

10+ version = "0.3";

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

12 buildDepends = [

13 reflex

@@ -17,7 +17,6 @@ mkDerivation {

17 these

18 lens

19 ghcjs-dom

20− safe

21 text

20 text

22 data-default

21 data-default

23 semigroups

22 semigroups

@@ -26,6 +25,7 @@ mkDerivation {

26 exception-transformers

25 exception-transformers

27 dependent-sum-template

26 dependent-sum-template

28 bifunctors

27 bifunctors

28+ bimap

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

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

30 license = null;

31}

reflex-dom.cabal+27−16

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

@@ -13,67 +13,78 @@ Cabal-version: >=1.9.2

13-- Deal with https://github.com/haskell/cabal/issues/2544 / https://github.com/haskell/cabal/issues/367

14extra-source-files: src-ghc/Reflex/Dom/Internal/Foreign.hs

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

16+ src-ghc/Reflex/Dom/WebSocket/Foreign.hs

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

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

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

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

19+ src-ghcjs/Reflex/Dom/WebSocket/Foreign.hs

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

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

19library

23library

20 hs-source-dirs: src

24 hs-source-dirs: src

21 build-depends:

25 build-depends:

22 base >= 4.7 && < 4.9,

26 base >= 4.7 && < 4.9,

23− reflex == 0.3.*,

27+ reflex == 0.4.*,

24− dependent-sum == 0.2.*,

28+ dependent-sum == 0.3.*,

25− dependent-map == 0.1.*,

29+ dependent-map == 0.2.*,

26− semigroups == 0.16.*,

30+ semigroups >= 0.16 && < 0.19,

27 mtl >= 2.1 && < 2.3,

31 mtl >= 2.1 && < 2.3,

28 containers == 0.5.*,

32 containers == 0.5.*,

29 these >= 0.4 && < 0.7,

33 these >= 0.4 && < 0.7,

30 ref-tf == 0.4.*,

34 ref-tf == 0.4.*,

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

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

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

32 lens >= 4.7 && < 4.14,

37 lens >= 4.7 && < 4.14,

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

34− safe == 0.3.*,

35 text == 1.2.*,

38 text == 1.2.*,

36 bytestring == 0.10.*,

39 bytestring == 0.10.*,

37 data-default == 0.5.*,

40 data-default == 0.5.*,

38− aeson >= 0.8 && < 0.10,

41+ aeson >= 0.8 && < 0.11,

39 time == 1.4.* || == 1.5.*,

42 time == 1.4.* || == 1.5.*,

40 exception-transformers == 0.4.*,

43 exception-transformers == 0.4.*,

41 directory == 1.2.*,

44 directory == 1.2.*,

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

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

43− bifunctors >= 4.2 && < 5.1

46+ bifunctors >= 4.2 && < 6,

47+ bimap >= 0.3 && < 0.4

45 if impl(ghcjs)

49 if impl(ghcjs)

46 hs-source-dirs: src-ghcjs

50 hs-source-dirs: src-ghcjs

47− cpp-options: -D__GHCJS__

48 build-depends:

51 build-depends:

49 ghcjs-base

52 ghcjs-base

50 else

53 else

51 hs-source-dirs: src-ghc

54 hs-source-dirs: src-ghc

52 build-depends:

55 build-depends:

53 glib == 0.13.*,

56 glib == 0.13.*,

54− gtk3 == 0.13.*,

57+ gtk3 >= 0.13.0 && < 0.15,

55− webkitgtk3 == 0.13.*,

58+ webkitgtk3 == 0.14.*,

56− webkitgtk3-javascriptcore == 0.13.*

59+ webkitgtk3-javascriptcore == 0.13.*,

60+ raw-strings-qq

61+ if !os(windows)

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

58 exposed-modules:

64 exposed-modules:

59 Reflex.Dom

65 Reflex.Dom

60 Reflex.Dom.Class

66 Reflex.Dom.Class

61 Reflex.Dom.DynamicWriter

67 Reflex.Dom.DynamicWriter

62 Reflex.Dom.Internal

68 Reflex.Dom.Internal

69+ Reflex.Dom.Time

70+ Reflex.Dom.WebSocket

63 Reflex.Dom.Widget

71 Reflex.Dom.Widget

64 Reflex.Dom.Widget.Basic

72 Reflex.Dom.Widget.Basic

65 Reflex.Dom.Widget.Input

73 Reflex.Dom.Widget.Input

66 Reflex.Dom.Widget.Lazy

74 Reflex.Dom.Widget.Lazy

67 Reflex.Dom.Widget.Resize

75 Reflex.Dom.Widget.Resize

68 Reflex.Dom.Xhr

76 Reflex.Dom.Xhr

69− Reflex.Dom.Time

77+ Reflex.Dom.Location

70 other-modules:

78 other-modules:

71 Reflex.Dom.Internal.Foreign

79 Reflex.Dom.Internal.Foreign

80+ Reflex.Dom.WebSocket.Foreign

72 Reflex.Dom.Xhr.Foreign

81 Reflex.Dom.Xhr.Foreign

82+ Reflex.Dom.Xhr.ResponseType

83+ Reflex.Dom.Xhr.Exception

74 other-extensions: TemplateHaskell

85 other-extensions: TemplateHaskell

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

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

77source-repository head

88source-repository head

78 type: git

89 type: git

79− location: https://github.com/ryantrinkle/reflex

90+ location: https://github.com/reflex-frp/reflex-dom

src-ghc/Reflex/Dom/Internal/Foreign.hs+103−9

@@ -1,19 +1,47 @@

1−{-# LANGUAGE ForeignFunctionInterface #-}

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

2module Reflex.Dom.Internal.Foreign where

4−import GHCJS.DOM hiding (runWebGUI)

5import Control.Concurrent

4import Control.Concurrent

5+import Control.Exception (bracket)

6+import Control.Lens hiding (set)

7+import Control.Monad

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

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

9+import Data.ByteString (ByteString)

10+import Data.List

11+import Foreign.Marshal hiding (void)

12+import Foreign.Ptr

13+import GHCJS.DOM hiding (runWebGUI)

7import GHCJS.DOM.Navigator

14import GHCJS.DOM.Navigator

8−import GHCJS.DOM.DOMWindow

15+import GHCJS.DOM.Window

9import Graphics.UI.Gtk hiding (Widget)

16import Graphics.UI.Gtk hiding (Widget)

10−import Graphics.UI.Gtk.WebKit.WebView

17+import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSBase

18+import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSObjectRef

19+import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSStringRef

20+import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSValueRef

21+import Graphics.UI.Gtk.WebKit.JavaScriptCore.WebFrame

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

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

12−import Graphics.UI.Gtk.WebKit.WebSettings

13import Graphics.UI.Gtk.WebKit.WebFrame

23import Graphics.UI.Gtk.WebKit.WebFrame

14import Graphics.UI.Gtk.WebKit.WebInspector

24import Graphics.UI.Gtk.WebKit.WebInspector

15−import Data.List

25+import Graphics.UI.Gtk.WebKit.WebSettings

26+import Graphics.UI.Gtk.WebKit.WebView

16import System.Directory

27import System.Directory

28+import System.Glib.FFI hiding (void)

29+import qualified Data.ByteString as BS

30+

31+#ifndef mingw32_HOST_OS

32+import System.Posix.Signals

33+#endif

34+

35+quitWebView :: WebView -> IO ()

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

37+ widgetDestroy w

38+

39+installQuitHandler :: WebView -> IO ()

40+#ifdef mingw32_HOST_OS

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

42+#else

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

44+#endif

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

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

19makeDefaultWebView userAgentKey main = do

47makeDefaultWebView userAgentKey main = do

@@ -50,6 +78,7 @@ makeDefaultWebView userAgentKey main = do

50 wf <- webViewGetMainFrame webView

78 wf <- webViewGetMainFrame webView

51 pwd <- getCurrentDirectory

79 pwd <- getCurrentDirectory

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

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

81+ installQuitHandler webView

53 mainGUI

82 mainGUI

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

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

@@ -62,8 +91,73 @@ runWebGUI' userAgentKey main = do

62 case mbWindow of

91 case mbWindow of

63 Just window -> do

92 Just window -> do

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

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

65− Just n <- domWindowGetNavigator window

94+ Just n <- getNavigator window

66− agent <- navigatorGetUserAgent n

95+ agent <- getUserAgent n

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

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

68 Nothing -> do

97 Nothing -> do

69 makeDefaultWebView userAgentKey main

98 makeDefaultWebView userAgentKey main

99+

100+foreign import ccall "wrapper"

101+ wrapper :: JSObjectCallAsFunctionCallback' -> IO JSObjectCallAsFunctionCallback

102+

103+toJSObject :: JSContextRef -> [Ptr OpaqueJSValue] -> IO JSObjectRef

104+toJSObject ctx args = do

105+ o <- jsobjectmake ctx nullPtr nullPtr

106+ iforM_ args $ \n a -> do

107+ prop <- jsstringcreatewithutf8cstring $ show n

108+ jsobjectsetproperty ctx o prop a 1 nullPtr

109+ return o

110+

111+fromJSStringMaybe :: JSContextRef -> JSValueRef -> IO (Maybe String)

112+fromJSStringMaybe c t = do

113+ isNull <- jsvalueisnull c t

114+ case isNull of

115+ True -> return Nothing

116+ False -> do

117+ j <- jsvaluetostringcopy c t nullPtr

118+ l <- jsstringgetmaximumutf8cstringsize j

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

120+ _ <- jsstringgetutf8cstring'_ j ps (fromIntegral l)

121+ peekCString ps

122+ return $ Just s

123+

124+getLocationHost :: WebView -> IO String

125+getLocationHost wv = withWebViewContext wv $ \c -> do

126+ script <- jsstringcreatewithutf8cstring "location.host"

127+ lh <- jsevaluatescript c script nullPtr nullPtr 1 nullPtr

128+ lh' <- fromJSStringMaybe c lh

129+ return $ maybe "" id lh'

130+

131+getLocationProtocol :: WebView -> IO String

132+getLocationProtocol wv = withWebViewContext wv $ \c -> do

133+ script <- jsstringcreatewithutf8cstring "location.protocol"

134+ lp <- jsevaluatescript c script nullPtr nullPtr 1 nullPtr

135+ lp' <- fromJSStringMaybe c lp

136+ return $ maybe "" id lp'

137+

138+bsToArrayBuffer :: JSContextRef -> ByteString -> IO JSValueRef

139+bsToArrayBuffer c bs = do

140+ elems <- forM (BS.unpack bs) $ \x -> jsvaluemakenumber c $ fromIntegral x

141+ let numElems = length elems

142+ bracket (mallocArray numElems) free $ \elemsArr -> do

143+ pokeArray elemsArr elems

144+ a <- jsobjectmakearray c (fromIntegral numElems) elemsArr nullPtr

145+ newUint8Array <- jsstringcreatewithutf8cstring "new Uint8Array(this)"

146+ jsevaluatescript c newUint8Array a nullPtr 1 nullPtr

147+

148+bsFromArrayBuffer :: JSContextRef -> JSValueRef -> IO ByteString

149+bsFromArrayBuffer c a = do

150+ let getIntegral = fmap round . (\x -> jsvaluetonumber c x nullPtr)

151+ getByteLength <- jsstringcreatewithutf8cstring "this.byteLength"

152+ byteLength <- getIntegral =<< jsevaluatescript c getByteLength a nullPtr 1 nullPtr

153+ toUint8Array <- jsstringcreatewithutf8cstring "new Uint8Array(this)"

154+ uint8Array <- jsevaluatescript c toUint8Array a nullPtr 1 nullPtr

155+ getIx <- jsstringcreatewithutf8cstring "this[0][this[1]]"

156+ let arrayLookup i = do

157+ i' <- jsvaluemakenumber c (fromIntegral i)

158+ args <- toJSObject c [uint8Array, i']

159+ getIntegral =<< jsevaluatescript c getIx args nullPtr 1 nullPtr

160+ fmap BS.pack $ forM [0..byteLength-1] arrayLookup

161+

162+withWebViewContext :: WebView -> (JSContextRef -> IO a) -> IO a

163+withWebViewContext wv f = f =<< webFrameGetGlobalContext =<< webViewGetMainFrame wv

src-ghc/Reflex/Dom/WebSocket/Foreign.hsnew file+70

@@ -0,0 +1,70 @@

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

3+module Reflex.Dom.WebSocket.Foreign where

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

7+import Control.Exception

8+import Control.Monad.State

9+import Data.ByteString (ByteString)

10+import Data.Text.Encoding

11+import Foreign.Marshal hiding (void)

12+import Foreign.Ptr

13+import Foreign.Storable

14+import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSBase

15+import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSObjectRef

16+import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSStringRef

17+import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSValueRef

18+import Graphics.UI.Gtk.WebKit.WebView

19+import qualified Data.ByteString as BS

20+import qualified Data.Text as T

21+

22+import Reflex.Dom.Internal.Foreign

23+

24+data JSWebSocket = JSWebSocket { wsValue :: JSValueRef

25+ , wsContext :: JSContextRef

26+ }

27+

28+newWebSocket :: WebView -> String -> (ByteString -> IO ()) -> IO () -> IO () -> IO JSWebSocket

29+newWebSocket wv url onMessage onOpen onClose = withWebViewContext wv $ \c -> do

30+ url' <- jsvaluemakestring c =<< jsstringcreatewithutf8cstring url

31+ newWSArgs <- toJSObject c [url']

32+ newWS <- jsstringcreatewithutf8cstring "(function(that) { var ws = new WebSocket(that[0]); ws['binaryType'] = 'arraybuffer'; return ws; })(this)"

33+ ws <- jsevaluatescript c newWS newWSArgs nullPtr 1 nullPtr

34+ onMessage' <- wrapper $ \_ _ _ _ args _ -> do

35+ e <- peekElemOff args 0

36+ dataProp <- jsstringcreatewithutf8cstring "data"

37+ msg <- jsobjectgetproperty c e dataProp nullPtr

38+ msg' <- fromJSStringMaybe c msg

39+ case msg' of

40+ Nothing -> return ()

41+ Just m -> onMessage $ encodeUtf8 $ T.pack m

42+ jsvaluemakeundefined c

43+ onMessageCb <- jsobjectmakefunctionwithcallback c nullPtr onMessage'

44+ onOpen' <- wrapper $ \_ _ _ _ _ _ -> do

45+ onOpen

46+ jsvaluemakeundefined c

47+ onOpenCb <- jsobjectmakefunctionwithcallback c nullPtr onOpen'

48+ onClose' <- wrapper $ \_ _ _ _ _ _ -> do

49+ onClose

50+ jsvaluemakeundefined c

51+ onCloseCb <- jsobjectmakefunctionwithcallback c nullPtr onClose'

52+ o <- toJSObject c [ws, onMessageCb, onOpenCb, onCloseCb]

53+ addCbs <- jsstringcreatewithutf8cstring "this[0]['onmessage'] = this[1]; this[0]['onopen'] = this[2]; this[0]['onclose'] = this[3];"

54+ _ <- jsevaluatescript c addCbs o nullPtr 1 nullPtr

55+ return $ JSWebSocket ws c

56+

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

58+webSocketSend (JSWebSocket ws c) bs = do

59+ elems <- forM (BS.unpack bs) $ \x -> jsvaluemakenumber c $ fromIntegral x

60+ let numElems = length elems

61+ bs' <- bracket (mallocArray numElems) free $ \elemsArr -> do

62+ pokeArray elemsArr elems

63+ a <- jsobjectmakearray c (fromIntegral numElems) elemsArr nullPtr

64+ newUint8Array <- jsstringcreatewithutf8cstring "new Uint8Array(this)"

65+ jsevaluatescript c newUint8Array a nullPtr 1 nullPtr

66+ send <- jsstringcreatewithutf8cstring "this[0]['send'](String['fromCharCode']['apply'](null, this[1]))"

67+ sendArgs <- toJSObject c [ws, bs']

68+ _ <- jsevaluatescript c send sendArgs nullPtr 1 nullPtr

69+ return ()

70+

src-ghc/Reflex/Dom/Xhr/Foreign.hs+101−50

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

1−{-# LANGUAGE ForeignFunctionInterface #-}

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

2module Reflex.Dom.Xhr.Foreign where

3module Reflex.Dom.Xhr.Foreign where

4−import Control.Lens.Indexed

5+import Control.Monad

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

@@ -10,7 +11,15 @@ import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSBase

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

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

11import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSStringRef

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

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

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

14+import Reflex.Dom.Xhr.ResponseType

15+import Reflex.Dom.Xhr.Exception

16+import Control.Concurrent.MVar

17+import Control.Exception.Base

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

18+import Graphics.UI.Gtk.WebKit.Types hiding (Text)

19+

20+import Reflex.Dom.Internal.Foreign

21+

22+import Text.RawString.QQ

15data XMLHttpRequest

24data XMLHttpRequest

16 = XMLHttpRequest { xhrValue :: JSValueRef

25 = XMLHttpRequest { xhrValue :: JSValueRef

@@ -18,30 +27,24 @@ data XMLHttpRequest

18 }

27 }

19 deriving (Eq, Ord)

28 deriving (Eq, Ord)

21−toJSObject :: JSContextRef -> [Ptr OpaqueJSValue] -> IO JSObjectRef

22−toJSObject ctx args = do

23− o <- jsobjectmake ctx nullPtr nullPtr

24− iforM_ args $ \n a -> do

25− prop <- jsstringcreatewithutf8cstring $ show n

26− jsobjectsetproperty ctx o prop a 1 nullPtr

27− return o

28−

29−responseTextToText :: Maybe String -> Maybe Text

30−responseTextToText = fmap T.pack

31−

32−statusTextToText :: String -> Text

33−statusTextToText = T.pack

34−

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

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

36stringToJSValue ctx s = jsvaluemakestring ctx =<< jsstringcreatewithutf8cstring s

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

33+fromResponseType :: XhrResponseType -> String

34+fromResponseType XhrResponseType_Default = ""

35+fromResponseType XhrResponseType_ArrayBuffer = "arraybuffer"

36+fromResponseType XhrResponseType_Blob = "blob"

37+fromResponseType XhrResponseType_Text = "text"

38+

38−toResponseType :: a -> a

39+toResponseType :: String -> Maybe XhrResponseType

39−toResponseType = id

40+toResponseType "" = Just XhrResponseType_Default

41+toResponseType "arraybuffer" = Just XhrResponseType_ArrayBuffer

42+toResponseType "blob" = Just XhrResponseType_Blob

43+toResponseType "text" = Just XhrResponseType_Text

44+toResponseType _ = Nothing

41xmlHttpRequestNew :: WebView -> IO XMLHttpRequest

46xmlHttpRequestNew :: WebView -> IO XMLHttpRequest

42−xmlHttpRequestNew wv = do

47+xmlHttpRequestNew wv = withWebViewContext wv $ \jsContext -> do

43− wf <- webViewGetMainFrame wv

44− jsContext <- webFrameGetGlobalContext wf

45 xhrScript <- jsstringcreatewithutf8cstring "new XMLHttpRequest()"

48 xhrScript <- jsstringcreatewithutf8cstring "new XMLHttpRequest()"

46 xhr' <- jsevaluatescript jsContext xhrScript nullPtr nullPtr 1 nullPtr

49 xhr' <- jsevaluatescript jsContext xhrScript nullPtr nullPtr 1 nullPtr

47 jsvalueprotect jsContext xhr'

50 jsvalueprotect jsContext xhr'

@@ -60,9 +63,6 @@ xmlHttpRequestOpen xhr method url async user password = do

60 _ <- jsevaluatescript c script o nullPtr 1 nullPtr

63 _ <- jsevaluatescript c script o nullPtr 1 nullPtr

61 return ()

64 return ()

63−foreign import ccall "wrapper"

64− wrapper :: JSObjectCallAsFunctionCallback' -> IO JSObjectCallAsFunctionCallback

65−

66xmlHttpRequestOnreadystatechange :: XMLHttpRequest -> IO () -> IO ()

67xmlHttpRequestOnreadystatechange xhr userCallback = do

68 let c = xhrContext xhr

@@ -83,38 +83,89 @@ xmlHttpRequestGetReadyState xhr = do

83 d <- jsvaluetonumber c rs nullPtr

84 return $ truncate d

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

86+xmlHttpRequestGetResponseType :: XMLHttpRequest -> IO (Maybe XhrResponseType)

87−xmlHttpRequestGetResponseText xhr = do

87+xmlHttpRequestGetResponseType xhr = do

88+ script <- jsstringcreatewithutf8cstring "this.responseType"

89+ rt <- jsevaluatescript (xhrContext xhr) script (xhrValue xhr) nullPtr 1 nullPtr

90+ ms <- fromJSStringMaybe (xhrContext xhr) rt

91+ return $ join $ fmap toResponseType ms

92+

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

94+xmlHttpRequestGetResponse xhr = do

88 let c = xhrContext xhr

95 let c = xhrContext xhr

96+ mrt <- xmlHttpRequestGetResponseType xhr

89− script <- jsstringcreatewithutf8cstring "this.responseText"

97+ script <- jsstringcreatewithutf8cstring "this.response"

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

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

91 isNull <- jsvalueisnull c t

99 isNull <- jsvalueisnull c t

92 case isNull of

100 case isNull of

93 True -> return Nothing

101 True -> return Nothing

94− False -> do

102+ False -> case mrt of

95− j <- jsvaluetostringcopy c t nullPtr

103+ Just XhrResponseType_ArrayBuffer -> Just . XhrResponseBody_ArrayBuffer <$> bsFromArrayBuffer c t

96− l <- jsstringgetmaximumutf8cstringsize j

104+ Just XhrResponseType_Blob -> Just . XhrResponseBody_Blob . Blob . castForeignPtr <$> newForeignPtr_ t

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

105+ Just XhrResponseType_Default -> fmap (XhrResponseBody_Default . T.pack) <$> fromJSStringMaybe c t

98− _ <- jsstringgetutf8cstring'_ j ps (fromIntegral l)

106+ Just XhrResponseType_Text -> fmap (XhrResponseBody_Text . T.pack) <$> fromJSStringMaybe c t

99− peekCString ps

100− return $ Just s

107+ _ -> return Nothing

108+

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

110+xmlHttpRequestGetResponseText xhr = do

111+ let c = xhrContext xhr

112+ script <- jsstringcreatewithutf8cstring "this.responseText"

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

114+ fmap (fmap T.pack) $ fromJSStringMaybe c t

101

115

102xmlHttpRequestSend :: XMLHttpRequest -> Maybe String -> IO ()

116xmlHttpRequestSend :: XMLHttpRequest -> Maybe String -> IO ()

103xmlHttpRequestSend xhr payload = do

117xmlHttpRequestSend xhr payload = do

104 let c = xhrContext xhr

118 let c = xhrContext xhr

119+ result <- newEmptyMVar

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

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

122+ onAbort <- jsobjectmakefunctionwithcallback c nullPtr a

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

124+ onError <- jsobjectmakefunctionwithcallback c nullPtr e

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

126+ onLoad <- jsobjectmakefunctionwithcallback c nullPtr l

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

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

106− Nothing -> do

128+ Nothing -> do

129+ d <- jsvaluemakeundefined c

107− o <- toJSObject c [xhrValue xhr]

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

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

131+ s <- jsstringcreatewithutf8cstring send

109− return (o,s)

132+ return (o,s)

110− Just payload' -> do

133+ Just payload' -> do

111− d <- stringToJSValue c payload'

134+ d <- stringToJSValue c payload'

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

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

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

136+ s <- jsstringcreatewithutf8cstring send

114− return (o,s)

137+ return (o,s)

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

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

116− return ()

139+ takeMVar result >>= mapM_ throwIO

117−

140+ where

141+ send = [r|

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

143+ var clear;

144+ var error = function () {

145+ clear(); onError();

146+ };

147+ var abort = function () {

148+ clear(); onAbort();

149+ };

150+ var load = function () {

151+ clear(); onLoad();

152+ };

153+ clear = function () {

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

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

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

157+ }

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

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

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

161+ if(d) {

162+ xhr.send(d);

163+ } else {

164+ xhr.send();

165+ }

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

167+ |]

168+

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

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

119xmlHttpRequestSetRequestHeader xhr header value = do

170xmlHttpRequestSetRequestHeader xhr header value = do

120 let c = xhrContext xhr

171 let c = xhrContext xhr

@@ -142,7 +193,7 @@ xmlHttpRequestGetStatus xhr = do

142 d <- jsvaluetonumber c s nullPtr

193 d <- jsvaluetonumber c s nullPtr

143 return $ truncate d

194 return $ truncate d

144

195

145−xmlHttpRequestGetStatusText :: XMLHttpRequest -> IO String

196+xmlHttpRequestGetStatusText :: XMLHttpRequest -> IO Text

146xmlHttpRequestGetStatusText xhr = do

197xmlHttpRequestGetStatusText xhr = do

147 let c = xhrContext xhr

198 let c = xhrContext xhr

148 script <- jsstringcreatewithutf8cstring "this.statusText"

199 script <- jsstringcreatewithutf8cstring "this.statusText"

@@ -152,4 +203,4 @@ xmlHttpRequestGetStatusText xhr = do

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

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

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

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

154 peekCString ps

205 peekCString ps

155− return s

206+ return $ T.pack s

src-ghcjs/Reflex/Dom/Internal/Foreign.hs+38−4

@@ -1,9 +1,43 @@

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

1−module Reflex.Dom.Internal.Foreign (runWebGUI) where

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

3+ , runWebGUI

4+ ) where

6+import Control.Monad

7+import Data.ByteString (ByteString)

8+import Foreign

9+import Foreign.C

3import GHCJS.DOM

10import GHCJS.DOM

4import GHCJS.DOM.Types

11import GHCJS.DOM.Types

5import GHCJS.Types

12import GHCJS.Types

6−import Data.Function

13+import JavaScript.TypedArray.ArrayBuffer as JS

14+import qualified Data.ByteString as BS

15+import qualified GHCJS.Buffer as JS

16+import qualified GHCJS.Marshal.Pure as JS

8−instance Eq Node where

18+quitWebView :: WebView -> IO ()

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

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

20+

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

22+

23+getLocationHost :: FromJSString r => a -> IO r

24+getLocationHost _ = liftM fromJSString getLocationHost_

25+

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

27+

28+getLocationProtocol :: FromJSString r => a -> IO r

29+getLocationProtocol _ = liftM fromJSString getLocationProtocol_

30+

31+withWebViewContext :: a -> (a -> IO b) -> IO b

32+withWebViewContext a f = f a

33+

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

35+

36+foreign import javascript unsafe "new Uint8Array($1_1['buf'], $1_2, $2)['buffer']" extractByteArray :: Ptr CChar -> Int -> IO JSVal

37+

38+bsToArrayBuffer :: a -> ByteString -> IO JSVal

39+bsToArrayBuffer _ bs = BS.useAsCString bs $ \cStr -> do

40+ extractByteArray cStr $ BS.length bs

41+

42+bsFromArrayBuffer :: a -> JSVal -> IO ByteString

43+bsFromArrayBuffer _ ab = liftM (JS.toByteString 0 Nothing . JS.createFromArrayBuffer) $ JS.unsafeFreeze $ JS.pFromJSVal ab

src-ghcjs/Reflex/Dom/WebSocket/Foreign.hsnew file+44

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

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

3+module Reflex.Dom.WebSocket.Foreign where

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

7+import Data.ByteString (ByteString)

8+import qualified Data.ByteString as BS

9+import GHCJS.Types

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)

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

20+

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

22+

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

24+newWebSocket _ url onMessage onOpen onClose = do

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

26+ _ <- on ws open $ liftIO onOpen

27+ GD.setBinaryType ws "arraybuffer"

28+ _ <- on ws message $ do

29+ e <- ask

30+ d <- getData e

31+ ab <- liftIO $ unsafeFreeze $ pFromJSVal d

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

33+ _ <- on ws closeEvent $ liftIO onClose

34+ return $ JSWebSocket ws

35+

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

37+webSocketSend (JSWebSocket ws) bs = do

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

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

40+ then jsval . getArrayBuffer <$> create 0

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

42+ GD.send ws $ Just ab

43+

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

src-ghcjs/Reflex/Dom/Xhr/Foreign.hs+117−365

@@ -1,399 +1,151 @@

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

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

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)

10−import Data.Word

11import GHCJS.DOM.Types hiding (Text)

12−import Control.Applicative ((<$>))

13−import GHCJS.DOM.EventM

14import GHCJS.DOM

12import GHCJS.DOM

15−import Data.Function

13+import GHCJS.DOM.Enums

14+import GHCJS.DOM.XMLHttpRequest

15+import Data.Maybe (fromMaybe)

16+import GHCJS.DOM.EventTarget (dispatchEvent)

17+import GHCJS.DOM.EventM (EventM, on)

18+import Reflex.Dom.Internal.Foreign

19+import Reflex.Dom.Xhr.Exception

20+import Reflex.Dom.Xhr.ResponseType

21+import Control.Exception (catch, throwIO)

17prepareWebView :: WebView -> IO ()

23prepareWebView :: WebView -> IO ()

18prepareWebView _ = return ()

24prepareWebView _ = return ()

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

26+xmlHttpRequestNew :: a -> IO XMLHttpRequest

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

27+xmlHttpRequestNew _ = newXMLHttpRequest

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

29+xmlHttpRequestOpen ::

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

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

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

32+xmlHttpRequestOpen = open

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

34+convertException :: XHRError -> XhrException

27− -> (obj -> obj')

35+convertException e = case e of

28−castTo gtype objTypeName obj =

36+ XHRError -> XhrException_Error

29− case toGObject obj of

37+ XHRAborted -> XhrException_Aborted

30− gobj@(GObject objRef)

31− | typeInstanceIsA objRef gtype

32− -> unsafeCastGObject gobj

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

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

40+xmlHttpRequestSend :: ToJSString payload => XMLHttpRequest -> Maybe payload -> IO ()

41+xmlHttpRequestSend self p = (maybe (send self) (sendString self) p) `catch` (throwIO . convertException)

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

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

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

45+xmlHttpRequestSetRequestHeader = setRequestHeader

38−instance Eq XMLHttpRequest where

47+xmlHttpRequestAbort :: XMLHttpRequest -> IO ()

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

48+xmlHttpRequestAbort = abort

41−instance ToJSRef XMLHttpRequest where

50+xmlHttpRequestGetAllResponseHeaders :: XMLHttpRequest -> IO Text

42− toJSRef = return . unXMLHttpRequest

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

43− {-# INLINE toJSRef #-}

53+xmlHttpRequestGetResponseHeader :: (ToJSString header)

45−instance FromJSRef XMLHttpRequest where

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

46− fromJSRef = return . fmap XMLHttpRequest . maybeJSNull

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

47− {-# INLINE fromJSRef #-}

49−class GObjectClass o => IsXMLHttpRequest o

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

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

58+xmlHttpRequestOverrideMimeType = overrideMimeType

51−toXMLHttpRequest = unsafeCastGObject . toGObject

53−instance IsXMLHttpRequest XMLHttpRequest

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

54−instance GObjectClass XMLHttpRequest where

61+xmlHttpRequestDispatchEvent = dispatchEvent

55− toGObject = GObject . castRef . unXMLHttpRequest

56− unsafeCastGObject = XMLHttpRequest . castRef . unGObject

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

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

59−castToXMLHttpRequest = castTo gTypeXMLHttpRequest "XMLHttpRequest"

64+xmlHttpRequestOnabort = (`on` abortEvent)

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

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

62−gTypeXMLHttpRequest :: GType

67+xmlHttpRequestOnerror = (`on` error)

63−gTypeXMLHttpRequest = GType gTypeXMLHttpRequest'

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

70+xmlHttpRequestOnload = (`on` load)

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

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

73+xmlHttpRequestOnloadend = (`on` loadEnd)

68−instance Eq XMLHttpRequestUpload where

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

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

76+xmlHttpRequestOnloadstart = (`on` loadStart)

71−instance ToJSRef XMLHttpRequestUpload where

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

72− toJSRef = return . unXMLHttpRequestUpload

79+xmlHttpRequestOnprogress = (`on` progress)

73− {-# INLINE toJSRef #-}

75−instance FromJSRef XMLHttpRequestUpload where

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

76− fromJSRef = return . fmap XMLHttpRequestUpload . maybeJSNull

82+xmlHttpRequestOntimeout = (`on` timeout)

77− {-# INLINE fromJSRef #-}

79−class GObjectClass o => IsXMLHttpRequestUpload o

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

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

85+xmlHttpRequestOnreadystatechange = (`on` readyStateChange)

81−toXMLHttpRequestUpload = unsafeCastGObject . toGObject

83−instance IsXMLHttpRequestUpload XMLHttpRequestUpload

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

84−instance GObjectClass XMLHttpRequestUpload where

88+xmlHttpRequestSetTimeout = setTimeout

85− toGObject = GObject . castRef . unXMLHttpRequestUpload

86− unsafeCastGObject = XMLHttpRequestUpload . castRef . unGObject

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

90+xmlHttpRequestGetTimeout :: XMLHttpRequest -> IO Word

89−castToXMLHttpRequestUpload = castTo gTypeXMLHttpRequestUpload "XMLHttpRequestUpload"

91+xmlHttpRequestGetTimeout = getTimeout

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

93+xmlHttpRequestGetReadyState :: XMLHttpRequest -> IO Word

92−gTypeXMLHttpRequestUpload :: GType

94+xmlHttpRequestGetReadyState = getReadyState

93−gTypeXMLHttpRequestUpload = GType gTypeXMLHttpRequestUpload'

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

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

96− ghcjs_dom_xml_http_request_new ::

97+xmlHttpRequestSetWithCredentials = setWithCredentials

97− IO (JSRef XMLHttpRequest)

99−xmlHttpRequestNew :: a -> IO XMLHttpRequest

99+xmlHttpRequestGetWithCredentials :: XMLHttpRequest -> IO Bool

100−xmlHttpRequestNew _ = XMLHttpRequest <$> ghcjs_dom_xml_http_request_new

100+xmlHttpRequestGetWithCredentials = getWithCredentials

101

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

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

103− ghcjs_dom_xml_http_request_open ::

103+xmlHttpRequestGetUpload = getUpload

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

105

104

106−xmlHttpRequestOpen ::

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

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

106+xmlHttpRequestGetResponseText = getResponseText

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

107+

109−xmlHttpRequestOpen self method url async user password

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

110− = ghcjs_dom_xml_http_request_open

109+xmlHttpRequestGetResponseXML = getResponseXML

111− (unXMLHttpRequest (toXMLHttpRequest self))

110+

112− (toJSString method)

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

113− (toJSString url)

112+xmlHttpRequestSetResponseType = setResponseType

114− (toJSBool async)

113+

115− (toJSString user)

114+fromResponseType :: XhrResponseType -> XMLHttpRequestResponseType

116− (toJSString password)

115+fromResponseType XhrResponseType_Default = XMLHttpRequestResponseType

117−

116+fromResponseType XhrResponseType_ArrayBuffer = XMLHttpRequestResponseTypeArraybuffer

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

117+fromResponseType XhrResponseType_Blob = XMLHttpRequestResponseTypeBlob

119− ghcjs_dom_xml_http_request_send ::

118+fromResponseType XhrResponseType_Text = XMLHttpRequestResponseTypeText

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

119+

121−

120+toResponseType :: XMLHttpRequestResponseType -> Maybe XhrResponseType

122−xmlHttpRequestSend ::

121+toResponseType XMLHttpRequestResponseType = Just XhrResponseType_Default

123− (IsXMLHttpRequest self, ToJSString payload) =>

122+toResponseType XMLHttpRequestResponseTypeArraybuffer = Just XhrResponseType_ArrayBuffer

124− self -> Maybe payload -> IO ()

123+toResponseType XMLHttpRequestResponseTypeBlob = Just XhrResponseType_Blob

125−xmlHttpRequestSend self payload

124+toResponseType XMLHttpRequestResponseTypeText = Just XhrResponseType_Text

126− = ghcjs_dom_xml_http_request_send

125+toResponseType _ = Nothing

127− (unXMLHttpRequest (toXMLHttpRequest self))

126+

128− (case payload of

127+xmlHttpRequestGetResponseType :: XMLHttpRequest -> IO (Maybe XhrResponseType)

129− Just p -> toJSString p

128+xmlHttpRequestGetResponseType = fmap toResponseType . getResponseType

130− Nothing -> jsNull)

129+

131−

130+xmlHttpRequestGetStatus :: XMLHttpRequest -> IO Word

132−

131+xmlHttpRequestGetStatus = getStatus

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

132+

134− ghcjs_dom_xml_http_request_set_request_header ::

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

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

134+xmlHttpRequestGetStatusText = getStatusText

136−

135+

137−xmlHttpRequestSetRequestHeader ::

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

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

137+xmlHttpRequestGetResponseURL = getResponseURL

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

138+

140−xmlHttpRequestSetRequestHeader self header value

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

141− = ghcjs_dom_xml_http_request_set_request_header

140+xmlHttpRequestGetResponse xhr = do

142− (unXMLHttpRequest (toXMLHttpRequest self))

141+ mr <- getResponse xhr

143− (toJSString header)

142+ rt <- xmlHttpRequestGetResponseType xhr

144− (toJSString value)

143+ case rt of

145−

144+ Just XhrResponseType_Blob -> return $ fmap (XhrResponseBody_Blob . castToBlob) mr

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

145+ Just XhrResponseType_Text -> fmap (Just . XhrResponseBody_Text) $ xmlHttpRequestGetStatusText xhr

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

146+ Just XhrResponseType_Default -> fmap (Just . XhrResponseBody_Text) $ xmlHttpRequestGetStatusText xhr

148−

147+ Just XhrResponseType_ArrayBuffer -> case (fmap unGObject mr) of

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

148+ Nothing -> return Nothing

150−xmlHttpRequestAbort self

149+ Just ptr -> fmap (Just . XhrResponseBody_ArrayBuffer) $ bsFromArrayBuffer ptr ptr

151− = ghcjs_dom_xml_http_request_abort

150+ _ -> return Nothing

152− (unXMLHttpRequest (toXMLHttpRequest self))

153−

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

155− ghcjs_dom_xml_http_request_get_all_response_headers ::

156− JSRef XMLHttpRequest -> IO JSString

157−

158−xmlHttpRequestGetAllResponseHeaders ::

159− (IsXMLHttpRequest self, FromJSString result) =>

160− self -> IO result

161−xmlHttpRequestGetAllResponseHeaders self

162− = fromJSString <$>

163− (ghcjs_dom_xml_http_request_get_all_response_headers

164− (unXMLHttpRequest (toXMLHttpRequest self)))

165−

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

167− ghcjs_dom_xml_http_request_get_response_header ::

168− JSRef XMLHttpRequest -> JSString -> IO JSString

169−

170−xmlHttpRequestGetResponseHeader ::

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

172− self -> header -> IO result

173−xmlHttpRequestGetResponseHeader self header

174− = fromJSString <$>

175− (ghcjs_dom_xml_http_request_get_response_header

176− (unXMLHttpRequest (toXMLHttpRequest self))

177− (toJSString header))

178−

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

180− ghcjs_dom_xml_http_request_override_mime_type ::

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

182−

183−xmlHttpRequestOverrideMimeType ::

184− (IsXMLHttpRequest self, ToJSString override) =>

185− self -> override -> IO ()

186−xmlHttpRequestOverrideMimeType self override

187− = ghcjs_dom_xml_http_request_override_mime_type

188− (unXMLHttpRequest (toXMLHttpRequest self))

189− (toJSString override)

190−

191−foreign import javascript unsafe

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

193− ghcjs_dom_xml_http_request_dispatch_event ::

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

195−

196−xmlHttpRequestDispatchEvent ::

197− (IsXMLHttpRequest self, IsEvent evt) =>

198− self -> Maybe evt -> IO Bool

199−xmlHttpRequestDispatchEvent self evt

200− = ghcjs_dom_xml_http_request_dispatch_event

201− (unXMLHttpRequest (toXMLHttpRequest self))

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

203−

204−cUNSENT :: Integer

205−cUNSENT = 0

206−

207−cOPENED :: Integer

208−cOPENED = 1

209−

210−cHEADERS_RECEIVED :: Integer

211−cHEADERS_RECEIVED = 2

212−

213−cLOADING :: Integer

214−cLOADING = 3

215−

216−cDONE :: Integer

217−cDONE = 4

218−

219−xmlHttpRequestOnabort ::

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

221−xmlHttpRequestOnabort = (connect "abort")

222−

223−xmlHttpRequestOnerror ::

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

225−xmlHttpRequestOnerror = (connect "error")

226−

227−xmlHttpRequestOnload ::

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

229−xmlHttpRequestOnload = (connect "load")

230−

231−xmlHttpRequestOnloadend ::

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

233−xmlHttpRequestOnloadend = (connect "loadend")

234−

235−xmlHttpRequestOnloadstart ::

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

237−xmlHttpRequestOnloadstart = (connect "loadstart")

238−

239−xmlHttpRequestOnprogress ::

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

241−xmlHttpRequestOnprogress = (connect "progress")

242−

243−xmlHttpRequestOntimeout ::

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

245−xmlHttpRequestOntimeout = (connect "timeout")

246−

247−xmlHttpRequestOnreadystatechange ::

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

249−xmlHttpRequestOnreadystatechange = (connect "readystatechange")

250−

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

252− ghcjs_dom_xml_http_request_set_timeout ::

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

254−

255−xmlHttpRequestSetTimeout ::

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

257−xmlHttpRequestSetTimeout self val

258− = ghcjs_dom_xml_http_request_set_timeout

259− (unXMLHttpRequest (toXMLHttpRequest self))

260− val

261−

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

263− ghcjs_dom_xml_http_request_get_timeout ::

264− JSRef XMLHttpRequest -> IO Word

265−

266−xmlHttpRequestGetTimeout ::

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

268−xmlHttpRequestGetTimeout self

269− = ghcjs_dom_xml_http_request_get_timeout

270− (unXMLHttpRequest (toXMLHttpRequest self))

271−

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

273− ghcjs_dom_xml_http_request_get_ready_state ::

274− JSRef XMLHttpRequest -> IO Word

275−

276−xmlHttpRequestGetReadyState ::

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

278−xmlHttpRequestGetReadyState self

279− = ghcjs_dom_xml_http_request_get_ready_state

280− (unXMLHttpRequest (toXMLHttpRequest self))

281−

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

283− ghcjs_dom_xml_http_request_set_with_credentials ::

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

285−

286−xmlHttpRequestSetWithCredentials ::

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

288−xmlHttpRequestSetWithCredentials self val

289− = ghcjs_dom_xml_http_request_set_with_credentials

290− (unXMLHttpRequest (toXMLHttpRequest self))

291− val

292−

293−foreign import javascript unsafe

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

295− ghcjs_dom_xml_http_request_get_with_credentials ::

296− JSRef XMLHttpRequest -> IO Bool

297−

298−xmlHttpRequestGetWithCredentials ::

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

300−xmlHttpRequestGetWithCredentials self

301− = ghcjs_dom_xml_http_request_get_with_credentials

302− (unXMLHttpRequest (toXMLHttpRequest self))

303−

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

305− ghcjs_dom_xml_http_request_get_upload ::

306− JSRef XMLHttpRequest -> IO (JSRef XMLHttpRequestUpload)

307−

308−xmlHttpRequestGetUpload ::

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

310−xmlHttpRequestGetUpload self

311− = fmap XMLHttpRequestUpload . maybeJSNull <$>

312− (ghcjs_dom_xml_http_request_get_upload

313− (unXMLHttpRequest (toXMLHttpRequest self)))

314−

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

316− ghcjs_dom_xml_http_request_get_response_text ::

317− JSRef XMLHttpRequest -> IO JSString

318−

319−xmlHttpRequestGetResponseText ::

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

321−xmlHttpRequestGetResponseText self

322− = fmap fromJSString . maybeJSNull <$>

323− (ghcjs_dom_xml_http_request_get_response_text

324− (unXMLHttpRequest (toXMLHttpRequest self)))

325−

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

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

328−

329−statusTextToText :: Text -> Text

330−statusTextToText = id

331−

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

333− ghcjs_dom_xml_http_request_get_response_xml ::

334− JSRef XMLHttpRequest -> IO (JSRef Document)

335−

336−xmlHttpRequestGetResponseXML ::

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

338−xmlHttpRequestGetResponseXML self

339− = fmap Document . maybeJSNull <$>

340− (ghcjs_dom_xml_http_request_get_response_xml

341− (unXMLHttpRequest (toXMLHttpRequest self)))

342−

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

344− ghcjs_dom_xml_http_request_set_response_type ::

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

346−

347−xmlHttpRequestSetResponseType ::

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

349−xmlHttpRequestSetResponseType self val

350− = ghcjs_dom_xml_http_request_set_response_type

351− (unXMLHttpRequest (toXMLHttpRequest self))

352− (toJSString val)

353−

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

355−toResponseType = toJSString

356−

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

358− ghcjs_dom_xml_http_request_get_response_type ::

359− JSRef XMLHttpRequest -> IO JSString

360−

361−xmlHttpRequestGetResponseType ::

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

363−xmlHttpRequestGetResponseType self

364− = fromJSString <$>

365− (ghcjs_dom_xml_http_request_get_response_type

366− (unXMLHttpRequest (toXMLHttpRequest self)))

367−

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

369− ghcjs_dom_xml_http_request_get_status ::

370− JSRef XMLHttpRequest -> IO Word

371−

372−xmlHttpRequestGetStatus ::

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

374−xmlHttpRequestGetStatus self

375− = ghcjs_dom_xml_http_request_get_status

376− (unXMLHttpRequest (toXMLHttpRequest self))

377−

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

379− ghcjs_dom_xml_http_request_get_status_text ::

380− JSRef XMLHttpRequest -> IO JSString

381−

382−xmlHttpRequestGetStatusText ::

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

384−xmlHttpRequestGetStatusText self

385− = fromJSString <$>

386− (ghcjs_dom_xml_http_request_get_status_text

387− (unXMLHttpRequest (toXMLHttpRequest self)))

388−

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

390− ghcjs_dom_xml_http_request_get_response_url ::

391− JSRef XMLHttpRequest -> IO JSString

392−

393−xmlHttpRequestGetResponseURL ::

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

395−xmlHttpRequestGetResponseURL self

396− = fromJSString <$>

397− (ghcjs_dom_xml_http_request_get_response_url

398− (unXMLHttpRequest (toXMLHttpRequest self)))

399

151

src/Reflex/Dom.hs+4

@@ -5,6 +5,8 @@ module Reflex.Dom ( module Reflex

5 , module Reflex.Dom.Xhr

6 , module Reflex.Dom.Time

7 , module Reflex.Dom.DynamicWriter

8+ , module Reflex.Dom.WebSocket

9+ , module Reflex.Dom.Location

8 ) where

10 ) where

10import Reflex

12import Reflex

@@ -14,3 +16,5 @@ import Reflex.Dom.Widget

14import Reflex.Dom.Xhr

16import Reflex.Dom.Xhr

15import Reflex.Dom.Time

17import Reflex.Dom.Time

16import Reflex.Dom.DynamicWriter

18import Reflex.Dom.DynamicWriter

19+import Reflex.Dom.WebSocket

20+import Reflex.Dom.Location

src/Reflex/Dom/Class.hs+3−3

@@ -89,13 +89,13 @@ instance MonadIORestore m => MonadIORestore (ReaderT r m) where

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

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

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

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

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

95runFrameWithTriggerRef r a = do

96 postGui <- askPostGui

97 runWithActions <- askRunWithActions

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

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

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

101 askPostGui = lift askPostGui

@@ -148,7 +148,7 @@ performEventAsync e = do

148 addVoidAction $ ffor e $ \o -> do

149 postGui <- askPostGui

150 runWithActions <- askRunWithActions

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

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

152 return eResult

153

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

src/Reflex/Dom/Internal.hs+16−12

@@ -9,7 +9,7 @@ import Reflex.Dom.Class

9import GHCJS.DOM hiding (runWebGUI)

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

11import GHCJS.DOM.Node

12−import GHCJS.DOM.HTMLElement

12+import GHCJS.DOM.Element

13import GHCJS.DOM.Document

14import Reflex.Class

15import Reflex.Host.Class

@@ -33,7 +33,7 @@ import Data.Monoid ((<>))

33data GuiEnv t h

34 = GuiEnv { _guiEnvDocument :: !HTMLDocument

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

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

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

37 , _guiEnvWebView :: !WebView

38 }

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

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

163 getRunWidget = return runWidget

164

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

166+getQuitWidget = return $ do wv <- askWebView

167+ liftIO $ quitWebView wv

168+

165runWidget :: (Monad m, Reflex t, IsNode n) => n -> Widget t (Gui t h m) a -> WidgetHost (Widget t (Gui t h m)) (a, WidgetHost (Widget t (Gui t h m)) (), Event t (WidgetHost (Widget t (Gui t h m)) ()))

169runWidget :: (Monad m, Reflex t, IsNode n) => n -> Widget t (Gui t h m) a -> WidgetHost (Widget t (Gui t h m)) (a, WidgetHost (Widget t (Gui t h m)) (), Event t (WidgetHost (Widget t (Gui t h m)) ()))

166runWidget rootElement w = do

170runWidget rootElement w = do

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

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

@@ -179,23 +183,23 @@ holdOnStartup a0 ma = do

179mainWidget :: Widget Spider (Gui Spider (WithWebView SpiderHost) (HostFrame Spider)) () -> IO ()

183mainWidget :: Widget Spider (Gui Spider (WithWebView SpiderHost) (HostFrame Spider)) () -> IO ()

180mainWidget w = runWebGUI $ \webView -> do

184mainWidget w = runWebGUI $ \webView -> do

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

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

182− Just body <- documentGetBody doc

186+ Just body <- getBody doc

183 attachWidget body webView w

187 attachWidget body webView w

184

188

185mainWidgetWithHead :: Widget Spider (Gui Spider (WithWebView SpiderHost) (HostFrame Spider)) () -> Widget Spider (Gui Spider (WithWebView SpiderHost) (HostFrame Spider)) () -> IO ()

189mainWidgetWithHead :: Widget Spider (Gui Spider (WithWebView SpiderHost) (HostFrame Spider)) () -> Widget Spider (Gui Spider (WithWebView SpiderHost) (HostFrame Spider)) () -> IO ()

186mainWidgetWithHead h b = runWebGUI $ \webView -> do

190mainWidgetWithHead h b = runWebGUI $ \webView -> do

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

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

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

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

189 attachWidget headElement webView h

193 attachWidget headElement webView h

190− Just body <- documentGetBody doc

194+ Just body <- getBody doc

191 attachWidget body webView b

195 attachWidget body webView b

192

196

193mainWidgetWithCss :: ByteString -> Widget Spider (Gui Spider (WithWebView SpiderHost) (HostFrame Spider)) () -> IO ()

197mainWidgetWithCss :: ByteString -> Widget Spider (Gui Spider (WithWebView SpiderHost) (HostFrame Spider)) () -> IO ()

194mainWidgetWithCss css w = runWebGUI $ \webView -> do

198mainWidgetWithCss css w = runWebGUI $ \webView -> do

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

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

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

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

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

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

198− Just body <- documentGetBody doc

202+ Just body <- getBody doc

199 attachWidget body webView w

203 attachWidget body webView w

200

204

201newtype WithWebView m a = WithWebView { unWithWebView :: ReaderT WebView m a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadException, MonadAsyncException)

205newtype WithWebView m a = WithWebView { unWithWebView :: ReaderT WebView m a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadException, MonadAsyncException)

@@ -245,20 +249,20 @@ runWithWebView = runReaderT . unWithWebView

245

249

246attachWidget :: (IsHTMLElement e) => e -> WebView -> Widget Spider (Gui Spider (WithWebView SpiderHost) (HostFrame Spider)) a -> IO a

250attachWidget :: (IsHTMLElement e) => e -> WebView -> Widget Spider (Gui Spider (WithWebView SpiderHost) (HostFrame Spider)) a -> IO a

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

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

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

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

249 frames <- liftIO newChan

253 frames <- liftIO newChan

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

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

251 runWithActions dm = do

255 runWithActions dm = do

252 voidActionNeeded <- fireEventsAndRead dm $ do

256 voidActionNeeded <- fireEventsAndRead dm $ do

253 sequence =<< readEvent voidActionHandle

257 sequence =<< readEvent voidActionHandle

254 runHostFrame $ runGui (sequence_ voidActionNeeded) guiEnv

258 runHostFrame $ runGui (sequence_ voidActionNeeded) guiEnv

255− Just df <- liftIO $ documentCreateDocumentFragment doc

259+ Just df <- createDocumentFragment doc

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

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

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

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

258 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

262 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

259 return (r, va)

263 return (r, va)

260− liftIO $ htmlElementSetInnerHTML rootElement ""

264+ setInnerHTML rootElement $ Just ""

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

265+ _ <- appendChild rootElement $ Just df

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

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

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

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

264 _ <- liftIO $ forkIO $ forever $ postGUISync =<< readChan frames -- postGUISync is necessary to prevent segfaults in GTK, which is not thread-safe

268 _ <- liftIO $ forkIO $ forever $ postGUISync =<< readChan frames -- postGUISync is necessary to prevent segfaults in GTK, which is not thread-safe

src/Reflex/Dom/Location.hsnew file+3

@@ -0,0 +1,3 @@

1+module Reflex.Dom.Location (getLocationHost, getLocationProtocol) where

3+import Reflex.Dom.Internal.Foreign

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

@@ -63,7 +63,7 @@ delay dt e = performEventAsync $ ffor e $ \a cb -> liftIO $ void $ forkIO $ do

63 threadDelay $ ceiling $ dt * 1000000

64 cb a

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

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

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

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

69debounce dt e = do

src/Reflex/Dom/WebSocket.hsnew file+68

@@ -0,0 +1,68 @@

3+module Reflex.Dom.WebSocket where

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

7+import Reflex

8+import Reflex.Host.Class

9+import Reflex.Dom.Class

10+import Reflex.Dom.WebSocket.Foreign

11+

12+import Control.Concurrent

13+import Control.Lens

14+import Control.Monad hiding (forM, forM_, mapM, mapM_, sequence)

15+import Control.Monad.IO.Class

16+import Control.Monad.Ref

17+import Control.Monad.State

18+import Data.ByteString (ByteString)

19+import Data.Default

20+import Data.Dependent.Map (DSum (..))

21+import Data.IORef

22+

23+data WebSocketConfig t

24+ = WebSocketConfig { _webSocketConfig_send :: Event t [ByteString]

25+ }

26+

27+instance Reflex t => Default (WebSocketConfig t) where

28+ def = WebSocketConfig never

29+

30+data WebSocket t

31+ = WebSocket { _webSocket_recv :: Event t ByteString

32+ , _webSocket_open :: Event t ()

33+ }

34+

35+webSocket :: forall t m. (HasWebView m, MonadWidget t m) => String -> WebSocketConfig t -> m (WebSocket t)

36+webSocket url config = do

37+ wv <- askWebView

38+ postGui <- askPostGui

39+ runWithActions <- askRunWithActions

40+ (eRecv, eRecvTriggerRef) <- newEventWithTriggerRef

41+ currentSocketRef <- liftIO $ newIORef Nothing

42+ --TODO: Disconnect if value no longer needed

43+ (eOpen, eOpenTriggerRef) <- newEventWithTriggerRef

44+ let onMessage :: ByteString -> IO ()

45+ onMessage m = postGui $ do

46+ mt <- readRef eRecvTriggerRef

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

48+ onOpen = postGui $ do

49+ mt <- readRef eOpenTriggerRef

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?

54+ liftIO $ writeIORef currentSocketRef Nothing

55+ liftIO $ threadDelay 1000000

56+ start

57+ liftIO $ writeIORef currentSocketRef $ Just ws

58+ return ()

59+ schedulePostBuild $ liftIO start

60+ performEvent_ $ ffor (_webSocketConfig_send config) $ \payloads -> forM_ payloads $ \payload -> do

61+ mws <- liftIO $ readIORef currentSocketRef

62+ case mws of

63+ Nothing -> return () -- Discard --TODO: should we do something better here? probably buffer it, since we handle reconnection logic; how do we verify that the server has received things?

64+ Just ws -> do

65+ liftIO $ webSocketSend ws payload

66+ return $ WebSocket eRecv eOpen

67+

68+makeLensesWith (lensRules & simpleLenses .~ True) ''WebSocketConfig

src/Reflex/Dom/Widget/Basic.hs+168−157

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

@@ -130,7 +130,7 @@ display a = dynText =<< mapDyn show a

130--TODO: Should this be renamed to 'widgetView' for consistency with 'widgetHold'?

131-- | Given a Dynamic of widget-creating actions, create a widget that is recreated whenever the Dynamic updates.

132-- The returned Event of widget results occurs when the Dynamic does.

133−-- Note: Often, the type 'a' is an Event, in which case the return value is an Event-of-Events that would typically be flattened.

133+-- Note: Often, the type 'a' is an Event, in which case the return value is an Event-of-Events that would typically be flattened (via 'switchPromptly').

134dyn :: MonadWidget t m => Dynamic t (m a) -> m (Event t a)

135dyn child = do

136 postBuild <- getPostBuild

@@ -158,17 +158,15 @@ widgetHoldInternal child0 newChild = do

158 tellWidgetOutput childOutput

159 doc <- askDocument

160 runWidget <- getRunWidget

161− let build c = do

162− Just df <- liftIO $ documentCreateDocumentFragment doc

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

164− runFrameWithTriggerRef newChildBuiltTriggerRef (result, voidActions)

165− postBuild

166− mp' <- liftIO $ nodeGetParentNode endPlaceholder

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

168− return ()

169 addVoidAction $ ffor newChild $ \c -> do

161 addVoidAction $ ffor newChild $ \c -> do

162+ Just df <- createDocumentFragment doc

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

164+ runFrameWithTriggerRef newChildBuiltTriggerRef (result, voidActions)

165+ postBuild

170 liftIO $ deleteBetweenExclusive startPlaceholder endPlaceholder

166 liftIO $ deleteBetweenExclusive startPlaceholder endPlaceholder

171− build c

167+ mp' <- getParentNode endPlaceholder

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

169+ return ()

172 return (result0, fmap fst newChildBuilt)

170 return (result0, fmap fst newChildBuilt)

173

171

174diffMapNoEq :: (Ord k) => Map k v -> Map k v -> Map k (Maybe v)

172diffMapNoEq :: (Ord k) => Map k v -> Map k v -> Map k (Maybe v)

@@ -209,7 +207,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

207 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

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

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

212− mkChild k v $ select childValChangedSelector $ Const2 k

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

213

211

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.

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

213listHoldWithKey :: (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 +222,13 @@ listHoldWithKey initialVals valsChanged mkChild = do

224 result <- mkChild k v

222 result <- mkChild k v

225 childEnd <- text' ""

223 childEnd <- text' ""

226 return (result, (childStart, childEnd))

224 return (result, (childStart, childEnd))

227− Just dfOrig <- liftIO $ documentCreateDocumentFragment doc

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

226 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

227 stateRef <- liftIO $ newIORef initialState

230 children <- holdDyn initialState newChildren

228 children <- holdDyn initialState newChildren

231 tellWidgetOutput =<< mapDyn (fmap snd) children

229 tellWidgetOutput =<< mapDyn (fmap snd) children

232− mpOrig <- liftIO $ nodeGetParentNode endPlaceholder

230+ mpOrig <- liftIO $ getParentNode endPlaceholder

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

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

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

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

235 curState <- liftIO $ readIORef stateRef

233 curState <- liftIO $ readIORef stateRef

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

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

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

240 return Nothing

238 return Nothing

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

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

242 liftIO $ deleteBetweenExclusive start end

240 liftIO $ deleteBetweenExclusive start end

243− Just df <- liftIO $ documentCreateDocumentFragment doc

241+ Just df <- createDocumentFragment doc

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

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

245 let s = (childResult, childVoidAction)

243 let s = (childResult, childVoidAction)

246 modify (>>childPostBuild)

244 modify (>>childPostBuild)

247− mp <- liftIO $ nodeGetParentNode end

245+ mp <- getParentNode end

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

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

249 return $ Just s

247 return $ Just s

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

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

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

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

252− Just df <- liftIO $ documentCreateDocumentFragment doc

250+ Just df <- createDocumentFragment doc

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

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

254 let s = (childResult, childVoidAction)

252 let s = (childResult, childVoidAction)

255 modify (>>childPostBuild)

253 modify (>>childPostBuild)

256 let placeholder = case Map.lookupGT k curState of

254 let placeholder = case Map.lookupGT k curState of

257 Nothing -> endPlaceholder

255 Nothing -> endPlaceholder

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

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

259− mp <- liftIO $ nodeGetParentNode placeholder

257+ mp <- getParentNode placeholder

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

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

261 return $ Just s

259 return $ Just s

262 This state -> do -- No change

260 This state -> do -- No change

263 return $ Just state

261 return $ Just state

@@ -303,47 +301,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

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

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

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

305deleteBetweenExclusive s e = do

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

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

305 case mCurrentParent of

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

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

309 Just currentParent -> do

307 Just currentParent -> do

310 let go = do

308 let go = do

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

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

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

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

313− _ <- nodeRemoveChild currentParent $ Just x

311+ _ <- removeChild currentParent $ Just x

314 go

312 go

315 go

313 go

316

314

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

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

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

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

319deleteBetweenInclusive s e = do

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

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

319 case mCurrentParent of

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

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

323 Just currentParent -> do

321 Just currentParent -> do

324 let go = do

322 let go = do

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

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

326− _ <- nodeRemoveChild currentParent $ Just x

324+ _ <- removeChild currentParent $ Just x

327 when (toNode s /= toNode x) go

325 when (toNode s /= toNode x) go

328 go

326 go

329− _ <- nodeRemoveChild currentParent $ Just e

327+ _ <- removeChild currentParent $ Just e

330 return ()

328 return ()

331

329

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

331+nodeClear n = do

332+ mfc <- getFirstChild n

333+ case mfc of

334+ Nothing -> return ()

335+ Just fc -> do

336+ _ <- removeChild n $ Just fc

337+ nodeClear n

338+

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

339--------------------------------------------------------------------------------

333-- Adapters

340-- Adapters

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

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

335

342

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)

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

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

338

345

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)

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

347wrapDomEventMaybe element elementOnevent getValue = do

341 postGui <- askPostGui

348 postGui <- askPostGui

342 runWithActions <- askRunWithActions

349 runWithActions <- askRunWithActions

343 e <- newEventWithTrigger $ \et -> do

350 e <- newEventWithTrigger $ \et -> do

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

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

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

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

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

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

347 return $ liftIO $ do

354 return $ liftIO $ do

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

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

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

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

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

377 | MouseoutTag

384 | MouseoutTag

378 | MouseoverTag

385 | MouseoverTag

379 | MouseupTag

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

387+ | MousewheelTag

381 | ScrollTag

388 | ScrollTag

382 | SelectTag

389 | SelectTag

383 | SubmitTag

390 | SubmitTag

384−-- | WheelTag -- See MousewheelTag

391+ | WheelTag

385 | BeforecutTag

392 | BeforecutTag

386 | CutTag

393 | CutTag

387 | BeforecopyTag

394 | BeforecopyTag

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

425 Mouseout :: EventName 'MouseoutTag

432 Mouseout :: EventName 'MouseoutTag

426 Mouseover :: EventName 'MouseoverTag

433 Mouseover :: EventName 'MouseoverTag

427 Mouseup :: EventName 'MouseupTag

434 Mouseup :: EventName 'MouseupTag

428− --Mousewheel :: EventName 'MousewheelTag

435+ Mousewheel :: EventName 'MousewheelTag

429 Scroll :: EventName 'ScrollTag

436 Scroll :: EventName 'ScrollTag

430 Select :: EventName 'SelectTag

437 Select :: EventName 'SelectTag

431 Submit :: EventName 'SubmitTag

438 Submit :: EventName 'SubmitTag

432− --Wheel :: EventName 'WheelTag

439+ Wheel :: EventName 'WheelTag

433 Beforecut :: EventName 'BeforecutTag

440 Beforecut :: EventName 'BeforecutTag

434 Cut :: EventName 'CutTag

441 Cut :: EventName 'CutTag

435 Beforecopy :: EventName 'BeforecopyTag

442 Beforecopy :: EventName 'BeforecopyTag

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

446

453

447type family EventType en where

454type family EventType en where

448 EventType 'AbortTag = UIEvent

455 EventType 'AbortTag = UIEvent

449− EventType 'BlurTag = UIEvent

456+ EventType 'BlurTag = FocusEvent

450− EventType 'ChangeTag = UIEvent

457+ EventType 'ChangeTag = DOM.Event

451 EventType 'ClickTag = MouseEvent

458 EventType 'ClickTag = MouseEvent

452 EventType 'ContextmenuTag = MouseEvent

459 EventType 'ContextmenuTag = MouseEvent

453 EventType 'DblclickTag = MouseEvent

460 EventType 'DblclickTag = MouseEvent

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

459 EventType 'DragstartTag = MouseEvent

466 EventType 'DragstartTag = MouseEvent

460 EventType 'DropTag = MouseEvent

467 EventType 'DropTag = MouseEvent

461 EventType 'ErrorTag = UIEvent

468 EventType 'ErrorTag = UIEvent

462− EventType 'FocusTag = UIEvent

469+ EventType 'FocusTag = FocusEvent

463− EventType 'InputTag = UIEvent

470+ EventType 'InputTag = DOM.Event

464− EventType 'InvalidTag = UIEvent

471+ EventType 'InvalidTag = DOM.Event

465− EventType 'KeydownTag = UIEvent

472+ EventType 'KeydownTag = KeyboardEvent

466− EventType 'KeypressTag = UIEvent

473+ EventType 'KeypressTag = KeyboardEvent

467− EventType 'KeyupTag = UIEvent

474+ EventType 'KeyupTag = KeyboardEvent

468 EventType 'LoadTag = UIEvent

475 EventType 'LoadTag = UIEvent

469 EventType 'MousedownTag = MouseEvent

476 EventType 'MousedownTag = MouseEvent

470− EventType 'MouseenterTag = UIEvent

477+ EventType 'MouseenterTag = MouseEvent

471− EventType 'MouseleaveTag = UIEvent

478+ EventType 'MouseleaveTag = MouseEvent

472 EventType 'MousemoveTag = MouseEvent

479 EventType 'MousemoveTag = MouseEvent

473 EventType 'MouseoutTag = MouseEvent

480 EventType 'MouseoutTag = MouseEvent

474 EventType 'MouseoverTag = MouseEvent

481 EventType 'MouseoverTag = MouseEvent

475 EventType 'MouseupTag = MouseEvent

482 EventType 'MouseupTag = MouseEvent

476− --EventType 'MousewheelTag = MouseEvent

483+ EventType 'MousewheelTag = MouseEvent

477 EventType 'ScrollTag = UIEvent

484 EventType 'ScrollTag = UIEvent

478 EventType 'SelectTag = UIEvent

485 EventType 'SelectTag = UIEvent

479− EventType 'SubmitTag = UIEvent

486+ EventType 'SubmitTag = DOM.Event

480− --EventType 'WheelTag = UIEvent

487+ EventType 'WheelTag = WheelEvent

481− EventType 'BeforecutTag = UIEvent

488+ EventType 'BeforecutTag = DOM.Event

482− EventType 'CutTag = UIEvent

489+ EventType 'CutTag = DOM.Event

483− EventType 'BeforecopyTag = UIEvent

490+ EventType 'BeforecopyTag = DOM.Event

484− EventType 'CopyTag = UIEvent

491+ EventType 'CopyTag = DOM.Event

485− EventType 'BeforepasteTag = UIEvent

492+ EventType 'BeforepasteTag = DOM.Event

486− EventType 'PasteTag = UIEvent

493+ EventType 'PasteTag = DOM.Event

487− EventType 'ResetTag = UIEvent

494+ EventType 'ResetTag = DOM.Event

488− EventType 'SearchTag = UIEvent

495+ EventType 'SearchTag = DOM.Event

489− EventType 'SelectstartTag = UIEvent

496+ EventType 'SelectstartTag = DOM.Event

490− EventType 'TouchstartTag = UIEvent

497+ EventType 'TouchstartTag = TouchEvent

491− EventType 'TouchmoveTag = UIEvent

498+ EventType 'TouchmoveTag = TouchEvent

492− EventType 'TouchendTag = UIEvent

499+ EventType 'TouchendTag = TouchEvent

493− EventType 'TouchcancelTag = UIEvent

500+ EventType 'TouchcancelTag = TouchEvent

494−

501+

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

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

496−onEventName en = case en of

503+onEventName en e = case en of

497− Abort -> elementOnabort

504+ Abort -> on e E.abort

498− Blur -> elementOnblur

505+ Blur -> on e E.blurEvent

499− Change -> elementOnchange

506+ Change -> on e E.change

500− Click -> elementOnclick

507+ Click -> on e E.click

501− Contextmenu -> elementOncontextmenu

508+ Contextmenu -> on e E.contextMenu

502− Dblclick -> elementOndblclick

509+ Dblclick -> on e E.dblClick

503− Drag -> elementOndrag

510+ Drag -> on e E.drag

504− Dragend -> elementOndragend

511+ Dragend -> on e E.dragEnd

505− Dragenter -> elementOndragenter

512+ Dragenter -> on e E.dragEnter

506− Dragleave -> elementOndragleave

513+ Dragleave -> on e E.dragLeave

507− Dragover -> elementOndragover

514+ Dragover -> on e E.dragOver

508− Dragstart -> elementOndragstart

515+ Dragstart -> on e E.dragStart

509− Drop -> elementOndrop

516+ Drop -> on e E.drop

510− Error -> elementOnerror

517+ Error -> on e E.error

511− Focus -> elementOnfocus

518+ Focus -> on e E.focusEvent

512− Input -> elementOninput

519+ Input -> on e E.input

513− Invalid -> elementOninvalid

520+ Invalid -> on e E.invalid

514− Keydown -> elementOnkeydown

521+ Keydown -> on e E.keyDown

515− Keypress -> elementOnkeypress

522+ Keypress -> on e E.keyPress

516− Keyup -> elementOnkeyup

523+ Keyup -> on e E.keyUp

517− Load -> elementOnload

524+ Load -> on e E.load

518− Mousedown -> elementOnmousedown

525+ Mousedown -> on e E.mouseDown

519− Mouseenter -> elementOnmouseenter

526+ Mouseenter -> on e E.mouseEnter

520− Mouseleave -> elementOnmouseleave

527+ Mouseleave -> on e E.mouseLeave

521− Mousemove -> elementOnmousemove

528+ Mousemove -> on e E.mouseMove

522− Mouseout -> elementOnmouseout

529+ Mouseout -> on e E.mouseOut

523− Mouseover -> elementOnmouseover

530+ Mouseover -> on e E.mouseOver

524− Mouseup -> elementOnmouseup

531+ Mouseup -> on e E.mouseUp

525− --Mousewheel -> elementOnmousewheel

532+ Mousewheel -> on e E.mouseWheel

526− Scroll -> elementOnscroll

533+ Scroll -> on e E.scroll

527− Select -> elementOnselect

534+ Select -> on e E.select

528− Submit -> elementOnsubmit

535+ Submit -> on e E.submit

529− --Wheel -> elementOnwheel

536+ Wheel -> on e E.wheel

530− Beforecut -> elementOnbeforecut

537+ Beforecut -> on e E.beforeCut

531− Cut -> elementOncut

538+ Cut -> on e E.cut

532− Beforecopy -> elementOnbeforecopy

539+ Beforecopy -> on e E.beforeCopy

533− Copy -> elementOncopy

540+ Copy -> on e E.copy

534− Beforepaste -> elementOnbeforepaste

541+ Beforepaste -> on e E.beforePaste

535− Paste -> elementOnpaste

542+ Paste -> on e E.paste

536− Reset -> elementOnreset

543+ Reset -> on e E.reset

537− Search -> elementOnsearch

544+ Search -> on e E.search

538− Selectstart -> elementOnselectstart

545+ Selectstart -> on e E.selectStart

539− Touchstart -> elementOntouchstart

546+ Touchstart -> on e E.touchStart

540− Touchmove -> elementOntouchmove

547+ Touchmove -> on e E.touchMove

541− Touchend -> elementOntouchend

548+ Touchend -> on e E.touchEnd

542− Touchcancel -> elementOntouchcancel

549+ Touchcancel -> on e E.touchCancel

543

550

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

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

545

552

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

588 EventResultType 'TouchmoveTag = ()

595 EventResultType 'TouchmoveTag = ()

589 EventResultType 'TouchendTag = ()

596 EventResultType 'TouchendTag = ()

590 EventResultType 'TouchcancelTag = ()

597 EventResultType 'TouchcancelTag = ()

598+ EventResultType 'MousewheelTag = ()

599+ EventResultType 'WheelTag = ()

591

600

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

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

602wrapDomEventsMaybe element handlers = do

594 postGui <- askPostGui

603 postGui <- askPostGui

595 runWithActions <- askRunWithActions

604 runWithActions <- askRunWithActions

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

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

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

606+ unsubscribe <- onEventName en element $ do

598 mv <- handlers en

607 mv <- handlers en

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

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

600 return $ liftIO $ do

609 return $ liftIO $ do

601 unsubscribe

610 unsubscribe

602 return $! e

611 return $! e

603

612

604−getKeyEvent :: EventM UIEvent e Int

613+getKeyEvent :: EventM e KeyboardEvent Int

605getKeyEvent = do

614getKeyEvent = do

606 e <- event

615 e <- event

607− liftIO $ do

616+ which <- getWhich e

608− which <- uiEventGetWhich e

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

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

610− charCode <- uiEventGetCharCode e

618+ charCode <- getCharCode e

611− if charCode /= 0 then return charCode else

619+ if charCode /= 0 then return charCode else

612− uiEventGetKeyCode e

620+ getKeyCode e

613−

621+

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

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

615getMouseEventCoords = do

623getMouseEventCoords = do

616 e <- event

624 e <- event

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

625+ bisequence (getX e, getY e)

618

626

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

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

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

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

621 Click -> return ()

629 Click -> return ()

622 Dblclick -> return ()

630 Dblclick -> return ()

623 Keypress -> getKeyEvent

631 Keypress -> getKeyEvent

632+ Scroll -> getScrollTop e

624 Keydown -> getKeyEvent

633 Keydown -> getKeyEvent

625 Keyup -> getKeyEvent

634 Keyup -> getKeyEvent

626− Scroll -> liftIO $ elementGetScrollTop e

627 Mousemove -> getMouseEventCoords

635 Mousemove -> getMouseEventCoords

628 Mouseup -> getMouseEventCoords

636 Mouseup -> getMouseEventCoords

629 Mousedown -> getMouseEventCoords

637 Mousedown -> getMouseEventCoords

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

662 Touchmove -> return ()

670 Touchmove -> return ()

663 Touchend -> return ()

671 Touchend -> return ()

664 Touchcancel -> return ()

672 Touchcancel -> return ()

673+ Mousewheel -> return ()

674+ Wheel -> return ()

665

675

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)

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

677wrapElement eh e = do

668 es <- wrapDomEventsMaybe e $ eh e

678 es <- wrapDomEventsMaybe e $ eh e

669 return $ El e es

679 return $ El e es

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

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

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

749elDynHtml' elementTag html = do

759elDynHtml' elementTag html = do

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

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

751− let h = castToHTMLElement e

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

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

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

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

754 wrapElement defaultDomEventHandler e

763 wrapElement defaultDomEventHandler e

755

764

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

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

757elDynHtmlAttr' elementTag attrs html = do

766elDynHtmlAttr' elementTag attrs html = do

758 e <- buildEmptyElement elementTag attrs

767 e <- buildEmptyElement elementTag attrs

759− let h = castToHTMLElement e

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

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

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

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

762 wrapElement defaultDomEventHandler e

770 wrapElement defaultDomEventHandler e

763

771

764data Link t

772data Link t

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

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

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

784

792

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

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

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

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

787

795

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

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

789linkClass s c = do

797linkClass s c = do

@@ -795,7 +803,7 @@ link s = linkClass s ""

795

803

796button :: MonadWidget t m => String -> m (Event t ())

804button :: MonadWidget t m => String -> m (Event t ())

797button s = do

805button s = do

798− (e, _) <- el' "button" $ text s

806+ (e, _) <- elAttr' "button" (Map.singleton "type" "button") $ text s

799 return $ domEvent Click e

807 return $ domEvent Click e

800

808

801newtype Workflow t m a = Workflow { unWorkflow :: m (a, Event t (Workflow t m a)) }

809newtype Workflow t m a = Workflow { unWorkflow :: m (a, Event t (Workflow t m a)) }

@@ -811,6 +819,9 @@ workflowView w0 = do

811 eReplace <- liftM switch $ hold never $ fmap snd eResult

819 eReplace <- liftM switch $ hold never $ fmap snd eResult

812 return $ fmap fst eResult

820 return $ fmap fst eResult

813

821

822+mapWorkflow :: (MonadWidget t m) => (a -> b) -> Workflow t m a -> Workflow t m b

823+mapWorkflow f (Workflow x) = Workflow (fmap (\(v,e) -> (f v, fmap (mapWorkflow f) e)) x)

824+

814divClass :: forall t m a. MonadWidget t m => String -> m a -> m a

825divClass :: forall t m a. MonadWidget t m => String -> m a -> m a

815divClass = elClass "div"

826divClass = elClass "div"

816

827

@@ -858,7 +869,7 @@ tabDisplay ulClass activeClass tabItems = do

858 _ <- listWithKey dTabs (\k dTab -> do

869 _ <- listWithKey dTabs (\k dTab -> do

859 dAttrs <- mapDyn (\sel -> do

870 dAttrs <- mapDyn (\sel -> do

860 let t1 = listToMaybe $ Map.keys tabItems

871 let t1 = listToMaybe $ Map.keys tabItems

861− if sel == Just k || (sel == Nothing && t1 == Just k) then Map.empty else Map.singleton "style" "display:none;") dCurrentTab

872+ if sel == Just k || (sel == Nothing && t1 == Just k) then Map.empty else Map.singleton "style" "display:none;") dCurrentTab

862 elDynAttr "div" dAttrs $ dyn =<< mapDyn snd dTab)

873 elDynAttr "div" dAttrs $ dyn =<< mapDyn snd dTab)

863 return ()

874 return ()

864 where

875 where

@@ -873,7 +884,7 @@ tabDisplay ulClass activeClass tabItems = do

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

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

874unsafePlaceElement e = do

885unsafePlaceElement e = do

875 p <- askParent

886 p <- askParent

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

887+ _ <- appendChild p $ Just e

877 wrapElement defaultDomEventHandler e

888 wrapElement defaultDomEventHandler e

878

889

879deriveGEq ''EventName

890deriveGEq ''EventName

src/Reflex/Dom/Widget/Input.hs+56−52

@@ -8,22 +8,24 @@ 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

19−import Data.Map as Map

19+import qualified Data.Map as Map

20−import Control.Lens

20+import Control.Lens hiding (ix)

21import Control.Monad hiding (forM_)

22import Control.Monad.IO.Class

23+import qualified Data.Bimap as B

23import Data.Default

24import Data.Default

24−import Data.Maybe

25−import Safe

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

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

26+import Data.Map (Map)

27+import Data.Maybe

28+import Text.Read

28data TextInput t

30data TextInput t

29 = TextInput { _textInput_value :: Dynamic t String

31 = TextInput { _textInput_value :: Dynamic t String

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

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

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

54textInput (TextInputConfig inputType initial eSetValue dAttrs) = do

56textInput (TextInputConfig inputType initial eSetValue dAttrs) = do

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

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

56− liftIO $ htmlInputElementSetValue e initial

58+ Input.setValue e $ Just initial

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

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

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

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

59 postGui <- askPostGui

61 postGui <- askPostGui

60 runWithActions <- askRunWithActions

62 runWithActions <- askRunWithActions

61 eChangeFocus <- newEventWithTrigger $ \eChangeFocusTrigger -> do

63 eChangeFocus <- newEventWithTrigger $ \eChangeFocusTrigger -> do

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

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

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

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

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

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

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

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

66 return $ liftIO $ unsubscribeOnblur >> unsubscribeOnfocus

68 return $ liftIO $ unsubscribeOnblur >> unsubscribeOnfocus

67 dFocus <- holdDyn False eChangeFocus

69 dFocus <- holdDyn False eChangeFocus

68− eKeypress <- wrapDomEvent e elementOnkeypress getKeyEvent

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

69− eKeydown <- wrapDomEvent e elementOnkeydown getKeyEvent

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

70− eKeyup <- wrapDomEvent e elementOnkeyup getKeyEvent

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

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

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

72 return $ TextInput dValue eChange eKeypress eKeydown eKeyup dFocus e

74 return $ TextInput dValue eChange eKeypress eKeydown eKeyup dFocus e

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

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

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

98textArea (TextAreaConfig initial eSet attrs) = do

100textArea (TextAreaConfig initial eSet attrs) = do

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

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

100− liftIO $ htmlTextAreaElementSetValue e initial

102+ TextArea.setValue e $ Just initial

101 postGui <- askPostGui

103 postGui <- askPostGui

102 runWithActions <- askRunWithActions

104 runWithActions <- askRunWithActions

103 eChangeFocus <- newEventWithTrigger $ \eChangeFocusTrigger -> do

105 eChangeFocus <- newEventWithTrigger $ \eChangeFocusTrigger -> do

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

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

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

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

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

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

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

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

108 return $ liftIO $ unsubscribeOnblur >> unsubscribeOnfocus

110 return $ liftIO $ unsubscribeOnblur >> unsubscribeOnfocus

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

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

110 f <- holdDyn False eChangeFocus

112 f <- holdDyn False eChangeFocus

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

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

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

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

113− eKeypress <- wrapDomEvent e elementOnkeypress getKeyEvent

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

114 return $ TextArea v ev e f eKeypress

116 return $ TextArea v ev e f eKeypress

115

117

116data CheckboxConfig t

118data CheckboxConfig t

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

135checkbox checked config = do

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

138 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

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

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

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

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

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

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

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

141 return $ Checkbox dValue eClick

143 return $ Checkbox dValue eClick

142

144

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

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

144checkboxView dAttrs dValue = do

146checkboxView dAttrs dValue = do

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

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

146− eClicked <- wrapDomEvent e elementOnclick $ do

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

147 preventDefault

149 preventDefault

148− liftIO $ htmlInputElementGetChecked e

150+ Input.getChecked e

149 schedulePostBuild $ do

151 schedulePostBuild $ do

150 v <- sample $ current dValue

152 v <- sample $ current dValue

151− when v $ liftIO $ htmlInputElementSetChecked e True

153+ when v $ Input.setChecked e True

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

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

153 return eClicked

155 return eClicked

154

156

155data FileInput t

157data FileInput t

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

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

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

169fileInput (FileInputConfig dAttrs) = do

171fileInput (FileInputConfig dAttrs) = do

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

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

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

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

172− Just files <- htmlInputElementGetFiles e

174+ Just files <- getFiles e

173− len <- fileListGetLength files

175+ len <- FileList.getLength files

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

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

175 dValue <- holdDyn [] eChange

177 dValue <- holdDyn [] eChange

176 return $ FileInput dValue e

178 return $ FileInput dValue e

177

179

@@ -191,26 +193,29 @@ instance (Reflex t, Ord k, Show k, Read k) => Default (DropdownConfig t k) where

191 }

193 }

192

194

193--TODO: We should allow the user to specify an ordering instead of relying on the ordering of the Map

195--TODO: We should allow the user to specify an ordering instead of relying on the ordering of the Map

194−--TODO: Get rid of Show k and Read k by indexing the possible values ourselves

195-- | Create a dropdown box

196-- | Create a dropdown box

196-- The first argument gives the initial value of the dropdown; if it is not present in the map of options provided, it will be added with an empty string as its text

197-- The first argument gives the initial value of the dropdown; if it is not present in the map of options provided, it will be added with an empty string as its text

197−dropdown :: forall k t m. (MonadWidget t m, Ord k, Show k, Read k) => k -> Dynamic t (Map k String) -> DropdownConfig t k -> m (Dropdown t k)

198+dropdown :: forall k t m. (MonadWidget t m, Ord k) => k -> Dynamic t (Map k String) -> DropdownConfig t k -> m (Dropdown t k)

198dropdown k0 options (DropdownConfig setK attrs) = do

199dropdown k0 options (DropdownConfig setK attrs) = do

200+ optionsWithAddedKeys <- combineDyn Map.union options <=< foldDyn Map.union (k0 =: "") $ fmap (=: "") setK

201+ defaultKey <- holdDyn k0 setK

202+ (indexedOptions, ixKeys) <- splitDyn <=< forDyn optionsWithAddedKeys $ \os ->

203+ let xs = map (\(ix, (k, v)) -> ((ix, k), ((ix, k), v))) $ zip [0::Int ..] $ Map.toList os

204+ ixVals = Map.fromList $ map snd xs

205+ ixKeys = B.fromList $ map fst xs

206+ in (ixVals, ixKeys)

199− (eRaw, _) <- elDynAttr' "select" attrs $ do

207+ (eRaw, _) <- elDynAttr' "select" attrs $ listWithKey indexedOptions $ \(ix, k) v -> do

200− optionsWithDefault <- mapDyn (`Map.union` (k0 =: "")) options

201− listWithKey optionsWithDefault $ \k v -> do

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

208+ optionAttrs <- mapDyn (\dk -> "value" =: show ix <> if dk == k then "selected" =: "selected" else mempty) defaultKey

209+ elDynAttr "option" optionAttrs $ dynText v

203 let e = castToHTMLSelectElement $ _el_element eRaw

210 let e = castToHTMLSelectElement $ _el_element eRaw

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

211+ performEvent_ $ fmap (Select.setValue e . Just . show) $ attachDynWithMaybe (flip B.lookupR) ixKeys setK

205− eChange <- wrapDomEvent e elementOnchange $ do

212+ eChange <- attachDynWith (\ks s -> join $ B.lookup <$> join (readMaybe <$> s) <*> pure ks) ixKeys <$> (wrapDomEvent e (`on` change) $ Select.getValue e)

206− kStr <- liftIO $ htmlSelectElementGetValue e

207− return $ readMay kStr

208− let readKey opts mk = fromMaybe k0 $ do

213+ let readKey keys mk = fromMaybe k0 $ do

209 k <- mk

214 k <- mk

210− guard $ Map.member k opts

215+ guard $ B.memberR k keys

211 return k

216 return k

212− dValue <- combineDyn readKey options =<< holdDyn (Just k0) (leftmost [eChange, fmap Just setK])

217+ dValue <- combineDyn readKey ixKeys <=< holdDyn (Just k0) $ leftmost [eChange, fmap Just setK]

213− return $ Dropdown dValue (attachDynWith readKey options eChange)

218+ return $ Dropdown dValue (attachDynWith readKey ixKeys eChange)

214

219

215liftM concat $ mapM makeLenses

220liftM concat $ mapM makeLenses

216 [ ''TextAreaConfig

221 [ ''TextAreaConfig

@@ -320,4 +325,3 @@ instance HasStateModeWitness Edit where

320instance HasStateModeWitness View where

325instance HasStateModeWitness View where

321 stateModeWitness = ViewWitness

326 stateModeWitness = ViewWitness

322-}

327-}

323−

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+107−25

@@ -1,9 +1,27 @@

1{-# LANGUAGE DeriveDataTypeable #-}

3module Reflex.Dom.Xhr

4− ( module Reflex.Dom.Xhr

5− , XMLHttpRequest

4+ ( XMLHttpRequest

6− , responseTextToText

5+ , XhrRequest(..)

6+ , XhrRequestConfig(..)

7+ , XhrResponse(..)

8+ , XhrResponseBody(..)

9+ , XhrResponseType(..)

10+ , XhrException(..)

11+ , _xhrResponse_body

12+ , xhrResponse_body

13+ , xhrRequest

14+ , newXMLHttpRequest

15+ , newXMLHttpRequestWithError

16+ , performRequestAsync

17+ , performRequestAsyncWithError

18+ , performRequestsAsync

19+ , performRequestsAsyncWithError

20+ , getAndDecode

21+ , postJson

22+ , getMay

23+ , decodeText

24+ , decodeXhrResponse

7 , xmlHttpRequestGetReadyState

25 , xmlHttpRequestGetReadyState

8 , xmlHttpRequestGetResponseText

26 , xmlHttpRequestGetResponseText

9 , xmlHttpRequestGetStatus

27 , xmlHttpRequestGetStatus

@@ -18,6 +36,7 @@ module Reflex.Dom.Xhr

18where

36where

20import Control.Concurrent

38import Control.Concurrent

39+import Control.Exception (catch)

21import Control.Lens

40import Control.Lens

22import Control.Monad hiding (forM)

41import Control.Monad hiding (forM)

23import Control.Monad.IO.Class

42import Control.Monad.IO.Class

@@ -35,7 +54,9 @@ import Data.Text.Encoding

35import Data.Traversable

54import Data.Traversable

36import Reflex

55import Reflex

37import Reflex.Dom.Class

56import Reflex.Dom.Class

57+import Reflex.Dom.Xhr.Exception

38import Reflex.Dom.Xhr.Foreign

58import Reflex.Dom.Xhr.Foreign

59+import Reflex.Dom.Xhr.ResponseType

39import Data.Typeable

60import Data.Typeable

41data XhrRequest

62data XhrRequest

@@ -49,17 +70,26 @@ data XhrRequestConfig

49 = XhrRequestConfig { _xhrRequestConfig_headers :: Map String String

70 = XhrRequestConfig { _xhrRequestConfig_headers :: Map String String

50 , _xhrRequestConfig_user :: Maybe String

71 , _xhrRequestConfig_user :: Maybe String

51 , _xhrRequestConfig_password :: Maybe String

72 , _xhrRequestConfig_password :: Maybe String

52− , _xhrRequestConfig_responseType :: Maybe String

73+ , _xhrRequestConfig_responseType :: Maybe XhrResponseType

53 , _xhrRequestConfig_sendData :: Maybe String

74 , _xhrRequestConfig_sendData :: Maybe String

54 }

75 }

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

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

57data XhrResponse

78data XhrResponse

58− = XhrResponse { _xhrResponse_body :: Maybe Text

59− , _xhrResponse_status :: Word

79+ = XhrResponse { _xhrResponse_status :: Word

60 , _xhrResponse_statusText :: Text

80 , _xhrResponse_statusText :: Text

81+ , _xhrResponse_response :: Maybe XhrResponseBody

82+ , _xhrResponse_responseText :: Maybe Text

61 }

83 }

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

84+ deriving (Typeable)

85+

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

87+_xhrResponse_body :: XhrResponse -> Maybe Text

88+_xhrResponse_body = _xhrResponse_responseText

89+

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

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

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

64instance Default XhrRequestConfig where

94instance Default XhrRequestConfig where

65 def = XhrRequestConfig { _xhrRequestConfig_headers = Map.empty

95 def = XhrRequestConfig { _xhrRequestConfig_headers = Map.empty

@@ -73,13 +103,26 @@ instance Default XhrRequestConfig where

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

103xhrRequest :: String -> String -> XhrRequestConfig -> XhrRequest

74xhrRequest = XhrRequest

104xhrRequest = XhrRequest

105

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

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

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

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

110+newXMLHttpRequestWithError

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

111+ :: (HasWebView m, MonadIO m, HasPostGui t h m)

77−newXMLHttpRequest req cb = do

112+ => XhrRequest

113+ -- ^ The request to make.

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

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

116+ -- case of error.

117+ -> m XMLHttpRequest

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

119+newXMLHttpRequestWithError req cb = do

78 wv <- askWebView

120 wv <- askWebView

79 postGui <- askPostGui

121 postGui <- askPostGui

80− liftIO $ do

81− xhr <- xmlHttpRequestNew wv

122+ xhr <- liftIO $ xmlHttpRequestNew wv

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

82 let c = _xhrRequest_config req

124 let c = _xhrRequest_config req

125+ rt = _xhrRequestConfig_responseType c

83 xmlHttpRequestOpen

126 xmlHttpRequestOpen

84 xhr

127 xhr

85 (_xhrRequest_method req)

128 (_xhrRequest_method req)

@@ -88,32 +131,71 @@ newXMLHttpRequest req cb = do

88 (fromMaybe "" $ _xhrRequestConfig_user c)

131 (fromMaybe "" $ _xhrRequestConfig_user c)

89 (fromMaybe "" $ _xhrRequestConfig_password c)

132 (fromMaybe "" $ _xhrRequestConfig_password c)

90 iforM_ (_xhrRequestConfig_headers c) $ xmlHttpRequestSetRequestHeader xhr

133 iforM_ (_xhrRequestConfig_headers c) $ xmlHttpRequestSetRequestHeader xhr

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

134+ maybe (return ()) (xmlHttpRequestSetResponseType xhr . fromResponseType) rt

92 _ <- xmlHttpRequestOnreadystatechange xhr $ do

135 _ <- xmlHttpRequestOnreadystatechange xhr $ do

93 readyState <- liftIO $ xmlHttpRequestGetReadyState xhr

136 readyState <- liftIO $ xmlHttpRequestGetReadyState xhr

94 status <- liftIO $ xmlHttpRequestGetStatus xhr

137 status <- liftIO $ xmlHttpRequestGetStatus xhr

95 statusText <- liftIO $ xmlHttpRequestGetStatusText xhr

138 statusText <- liftIO $ xmlHttpRequestGetStatusText xhr

96 if readyState == 4

139 if readyState == 4

97 then do

140 then do

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

98− r <- liftIO $ xmlHttpRequestGetResponseText xhr

142+ then liftIO $ xmlHttpRequestGetResponseText xhr

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

143+ else return Nothing

144+ r <- liftIO $ xmlHttpRequestGetResponse xhr

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

146+ XhrResponse { _xhrResponse_status = status

147+ , _xhrResponse_statusText = statusText

148+ , _xhrResponse_response = r

149+ , _xhrResponse_responseText = t

150+ }

100 return ()

151 return ()

101 else return ()

152 else return ()

102 _ <- xmlHttpRequestSend xhr (_xhrRequestConfig_sendData c)

153 _ <- xmlHttpRequestSend xhr (_xhrRequestConfig_sendData c)

103− return xhr

154+ return ()

155+ return xhr

156+

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

158+newXMLHttpRequest req cb = newXMLHttpRequestWithError req $ mapM_ cb

159+

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

161+-- Returns Event of corresponding responses.

162+--

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

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

165+performRequestAsyncWithError

166+ :: MonadWidget t m

167+ => Event t XhrRequest -> m (Event t (Either XhrException XhrResponse))

168+performRequestAsyncWithError = performRequestAsync' newXMLHttpRequestWithError

169+

170+performRequestAsync :: MonadWidget t m => Event t XhrRequest -> m (Event t XhrResponse)

171+performRequestAsync = performRequestAsync' newXMLHttpRequest

172+

173+performRequestAsync' :: (MonadWidget t m, MonadIO h) => (XhrRequest -> (a -> h ()) -> WidgetHost m XMLHttpRequest) -> Event t XhrRequest -> m (Event t a)

174+performRequestAsync' newXhr req = performEventAsync $ ffor req $ \r cb -> void $ newXhr r $ liftIO . cb

175+

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

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

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

179+--

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

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

182+--

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

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

185+performRequestsAsyncWithError

186+ :: (Traversable f, MonadWidget t m)

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

188+performRequestsAsyncWithError = performRequestsAsync' newXMLHttpRequestWithError

104

189

105−-- | Given Event of requests, issue them when the Event fires. Returns Event of corresponding responses.

106−performRequestAsync :: (MonadWidget t m) => Event t XhrRequest -> m (Event t XhrResponse)

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

108− _ <- newXMLHttpRequest r $ liftIO . cb

109− return ()

110

190

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.

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

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

192+performRequestsAsync = performRequestsAsync' newXMLHttpRequest

193+

194+performRequestsAsync' :: (MonadWidget t m, MonadIO h, Traversable f) => (XhrRequest -> (a -> h ()) -> WidgetHost m XMLHttpRequest) -> Event t (f XhrRequest) -> m (Event t (f a))

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

195+performRequestsAsync' newXhr req = performEventAsync $ ffor req $ \rs cb -> do

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

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

115 resp <- liftIO newEmptyMVar

197 resp <- liftIO newEmptyMVar

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

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

117 return resp

199 return resp

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

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

119 return ()

201 return ()

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

126

208

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

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

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

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

129−postJson url a =

211+postJson url a =

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

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

131 , _xhrRequestConfig_sendData = Just body

213 , _xhrRequestConfig_sendData = Just body

132 }

214 }

@@ -143,5 +225,5 @@ decodeText = decode . BL.fromStrict . encodeUtf8

143

225

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

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

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

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

146−decodeXhrResponse = join . fmap decodeText . _xhrResponse_body

228+decodeXhrResponse = join . fmap decodeText . _xhrResponse_responseText

147

229

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

@@ -0,0 +1,21 @@

1+{-# LANGUAGE DeriveDataTypeable #-}

3+module Reflex.Dom.Xhr.ResponseType where

5+import Data.Typeable

6+import Data.Text (Text)

7+import GHCJS.DOM.Blob (Blob)

8+import Data.ByteString (ByteString)

10+data XhrResponseType = XhrResponseType_Default

11+ | XhrResponseType_ArrayBuffer

12+ | XhrResponseType_Blob

13+ | XhrResponseType_Text

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

15+

16+data XhrResponseBody = XhrResponseBody_Default Text

17+ | XhrResponseBody_Text Text

18+ | XhrResponseBody_Blob Blob

19+ | XhrResponseBody_ArrayBuffer ByteString

20+ deriving (Eq)

21+

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