31d6ed4 · reflex-dom · git.iko.soy

git.iko.soy/reflex-dom

on develop help sign in

Merge branch 'develop-ghcjs-0.2.0' of https://github.com/k0001/reflex-dom into develop

31d6ed4Ryan Trinkle11 years ago

reflex-dom.cabal+6−7

compare with develop

unifiedsplit

@@ -23,14 +23,14 @@ library

23 reflex == 0.3.*,

24 dependent-sum == 0.2.*,

25 dependent-map == 0.1.*,

26− semigroups == 0.16.*,

26+ semigroups >= 0.16 && < 0.18,

27 mtl >= 2.1 && < 2.3,

28 containers == 0.5.*,

29 these >= 0.4 && < 0.7,

30 ref-tf == 0.4.*,

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

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

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

32 lens >= 4.7 && < 4.14,

33 lens >= 4.7 && < 4.14,

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

34 safe == 0.3.*,

35 text == 1.2.*,

36 bytestring == 0.10.*,

@@ -40,19 +40,18 @@ library

40 exception-transformers == 0.4.*,

41 directory == 1.2.*,

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

43− bifunctors >= 4.2 && < 5.1

43+ bifunctors >= 4.2 && < 6

45 if impl(ghcjs)

46 hs-source-dirs: src-ghcjs

47− cpp-options: -D__GHCJS__

48 build-depends:

47 build-depends:

49 ghcjs-base

48 ghcjs-base

50 else

49 else

51 hs-source-dirs: src-ghc

50 hs-source-dirs: src-ghc

52 build-depends:

51 build-depends:

53 glib == 0.13.*,

52 glib == 0.13.*,

54− gtk3 == 0.13.*,

53+ gtk3 >= 0.13.0 && < 0.15,

55− webkitgtk3 == 0.13.*,

54+ webkitgtk3 == 0.14.*,

56 webkitgtk3-javascriptcore == 0.13.*

55 webkitgtk3-javascriptcore == 0.13.*

58 exposed-modules:

57 exposed-modules:

@@ -73,7 +72,7 @@ library

73 Reflex.Dom.Xhr.Foreign

72 Reflex.Dom.Xhr.Foreign

75 other-extensions: TemplateHaskell

74 other-extensions: TemplateHaskell

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

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

78source-repository head

77source-repository head

79 type: git

78 type: git

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

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

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

8import Foreign.Ptr

9import GHCJS.DOM.Navigator

10−import GHCJS.DOM.DOMWindow

10+import GHCJS.DOM.Window

11import Graphics.UI.Gtk hiding (Widget)

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

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

@@ -69,8 +69,8 @@ runWebGUI' userAgentKey main = do

69 case mbWindow of

70 Just window -> do

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

72− Just n <- domWindowGetNavigator window

72+ Just n <- getNavigator window

73− agent <- navigatorGetUserAgent n

73+ agent <- getUserAgent n

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

75 Nothing -> do

76 makeDefaultWebView userAgentKey main

src-ghc/Reflex/Dom/Xhr/Foreign.hs+17−3

@@ -4,6 +4,7 @@ module Reflex.Dom.Xhr.Foreign where

4import Control.Lens.Indexed

5import qualified Data.Text as T

6import Data.Text (Text)

7+import Data.Typeable (Typeable)

7import System.Glib.FFI

8import System.Glib.FFI

8import Graphics.UI.Gtk.WebKit.WebView

9import Graphics.UI.Gtk.WebKit.WebView

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

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

@@ -29,8 +30,21 @@ statusTextToText = T.pack

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

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

30stringToJSValue ctx s = jsvaluemakestring ctx =<< jsstringcreatewithutf8cstring s

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

33+data XMLHttpRequestResponseType = XMLHttpRequestResponseType

34+ | XMLHttpRequestResponseTypeArraybuffer

35+ | XMLHttpRequestResponseTypeBlob

36+ | XMLHttpRequestResponseTypeDocument

37+ | XMLHttpRequestResponseTypeJson

38+ | XMLHttpRequestResponseTypeText

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

40+

32−toResponseType :: a -> a

41+toResponseType :: XMLHttpRequestResponseType -> String

33−toResponseType = id

42+toResponseType XMLHttpRequestResponseType = ""

43+toResponseType XMLHttpRequestResponseTypeArraybuffer = "arraybuffer"

44+toResponseType XMLHttpRequestResponseTypeBlob = "blob"

45+toResponseType XMLHttpRequestResponseTypeDocument = "document"

46+toResponseType XMLHttpRequestResponseTypeJson = "json"

47+toResponseType XMLHttpRequestResponseTypeText = "text"

35xmlHttpRequestNew :: WebView -> IO XMLHttpRequest

49xmlHttpRequestNew :: WebView -> IO XMLHttpRequest

36xmlHttpRequestNew wv = do

50xmlHttpRequestNew wv = do

@@ -105,7 +119,7 @@ xmlHttpRequestSend xhr payload = do

105 return (o,s)

119 return (o,s)

106 _ <- jsevaluatescript c s o nullPtr 1 nullPtr

120 _ <- jsevaluatescript c s o nullPtr 1 nullPtr

107 return ()

121 return ()

108−

122+

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

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

110xmlHttpRequestSetRequestHeader xhr header value = do

124xmlHttpRequestSetRequestHeader xhr header value = do

111 let c = xhrContext xhr

125 let c = xhrContext xhr

src-ghcjs/Reflex/Dom/Internal/Foreign.hs−6

@@ -1,9 +1,3 @@

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

3import GHCJS.DOM

4−import GHCJS.DOM.Types

5−import GHCJS.Types

6−import Data.Function

7−

8−instance Eq Node where

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

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

@@ -11,7 +11,32 @@ import qualified Data.ByteString as BS

11import Foreign.Ptr

12import GHCJS.Foreign

13import GHCJS.Types

14+import Data.JSString.Text

15+import GHCJS.DOM.WebSocket (WebSocket, message, closeEvent)

16+import qualified GHCJS.DOM.WebSocket as GD

17+import GHCJS.DOM.MessageEvent

18+import GHCJS.DOM.EventM (on)

19+import GHCJS.DOM.Types

20+import Control.Monad.IO.Class

21+import Control.Monad.Reader

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

24+

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

26+newWebSocket _ url onMessage onClose = do

27+ ws <- GD.newWebSocket url (Nothing :: Maybe [String])

28+ on ws message $ do

29+ e <- ask

30+ d <- getData e

31+ liftIO $ onMessage $ encodeUtf8 $ textFromJSVal d

32+ on ws closeEvent $ liftIO onClose

33+ return $ JSWebSocket ws

34+

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

36+webSocketSend (JSWebSocket ws) bs = do

37+ undefined

38+

39+{-

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

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

17newtype JSWebSocket = JSWebSocket { unWebSocket :: JSRef JSWebSocket }

42newtype JSWebSocket = JSWebSocket { unWebSocket :: JSRef JSWebSocket }

@@ -47,3 +72,4 @@ newWebSocket _ url onMessage onClose = do

47 onClose

72 onClose

48 liftM JSWebSocket $ newWebSocket_ (toJSString url) onMessageFun onCloseFun

73 liftM JSWebSocket $ newWebSocket_ (toJSString url) onMessageFun onCloseFun

75+-}

src-ghcjs/Reflex/Dom/Xhr/Foreign.hs+88−363

@@ -1,399 +1,124 @@

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)

17prepareWebView :: WebView -> IO ()

19prepareWebView :: WebView -> IO ()

18prepareWebView _ = return ()

20prepareWebView _ = return ()

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

22+xmlHttpRequestNew :: a -> IO XMLHttpRequest

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

23+xmlHttpRequestNew _ = newXMLHttpRequest -- XMLHttpRequest <$> ghcjs_dom_xml_http_request_new

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

25+xmlHttpRequestOpen ::

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

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

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

28+xmlHttpRequestOpen = open

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

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

27− -> (obj -> obj')

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

28−castTo gtype objTypeName obj =

32+xmlHttpRequestSend self = maybe (send self) (sendString self)

29− case toGObject obj of

30− gobj@(GObject objRef)

31− | typeInstanceIsA objRef gtype

32− -> unsafeCastGObject gobj

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

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

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

36+xmlHttpRequestSetRequestHeader = setRequestHeader

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

38+xmlHttpRequestAbort :: XMLHttpRequest -> IO ()

39+xmlHttpRequestAbort = abort

38−instance Eq XMLHttpRequest where

41+xmlHttpRequestGetAllResponseHeaders :: XMLHttpRequest -> IO Text

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

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

44+xmlHttpRequestGetResponseHeader :: (ToJSString header)

41−instance ToJSRef XMLHttpRequest where

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

42− toJSRef = return . unXMLHttpRequest

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

43− {-# INLINE toJSRef #-}

45−instance FromJSRef XMLHttpRequest where

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

46− fromJSRef = return . fmap XMLHttpRequest . maybeJSNull

49+xmlHttpRequestOverrideMimeType = overrideMimeType

47− {-# INLINE fromJSRef #-}

49−class GObjectClass o => IsXMLHttpRequest o

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

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

52+xmlHttpRequestDispatchEvent = dispatchEvent

51−toXMLHttpRequest = unsafeCastGObject . toGObject

53−instance IsXMLHttpRequest XMLHttpRequest

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

54−instance GObjectClass XMLHttpRequest where

55+xmlHttpRequestOnabort = (`on` abortEvent)

55− toGObject = GObject . castRef . unXMLHttpRequest

56− unsafeCastGObject = XMLHttpRequest . castRef . unGObject

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

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

59−castToXMLHttpRequest = castTo gTypeXMLHttpRequest "XMLHttpRequest"

58+xmlHttpRequestOnerror = (`on` error)

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

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

62−gTypeXMLHttpRequest :: GType

61+xmlHttpRequestOnload = (`on` load)

63−gTypeXMLHttpRequest = GType gTypeXMLHttpRequest'

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

64+xmlHttpRequestOnloadend = (`on` loadEnd)

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

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

67+xmlHttpRequestOnloadstart = (`on` loadStart)

68−instance Eq XMLHttpRequestUpload where

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

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

70+xmlHttpRequestOnprogress = (`on` progress)

71−instance ToJSRef XMLHttpRequestUpload where

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

72− toJSRef = return . unXMLHttpRequestUpload

73+xmlHttpRequestOntimeout = (`on` timeout)

73− {-# INLINE toJSRef #-}

75−instance FromJSRef XMLHttpRequestUpload where

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

76− fromJSRef = return . fmap XMLHttpRequestUpload . maybeJSNull

76+xmlHttpRequestOnreadystatechange = (`on` readyStateChange)

77− {-# INLINE fromJSRef #-}

79−class GObjectClass o => IsXMLHttpRequestUpload o

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

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

79+xmlHttpRequestSetTimeout = setTimeout

81−toXMLHttpRequestUpload = unsafeCastGObject . toGObject

83−instance IsXMLHttpRequestUpload XMLHttpRequestUpload

81+xmlHttpRequestGetTimeout :: XMLHttpRequest -> IO Word

84−instance GObjectClass XMLHttpRequestUpload where

82+xmlHttpRequestGetTimeout = getTimeout

85− toGObject = GObject . castRef . unXMLHttpRequestUpload

86− unsafeCastGObject = XMLHttpRequestUpload . castRef . unGObject

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

84+xmlHttpRequestGetReadyState :: XMLHttpRequest -> IO Word

89−castToXMLHttpRequestUpload = castTo gTypeXMLHttpRequestUpload "XMLHttpRequestUpload"

85+xmlHttpRequestGetReadyState = getReadyState

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

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

92−gTypeXMLHttpRequestUpload :: GType

88+xmlHttpRequestSetWithCredentials = setWithCredentials

93−gTypeXMLHttpRequestUpload = GType gTypeXMLHttpRequestUpload'

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

90+xmlHttpRequestGetWithCredentials :: XMLHttpRequest -> IO Bool

96− ghcjs_dom_xml_http_request_new ::

91+xmlHttpRequestGetWithCredentials = getWithCredentials

97− IO (JSRef XMLHttpRequest)

99−xmlHttpRequestNew :: a -> IO XMLHttpRequest

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

100−xmlHttpRequestNew _ = XMLHttpRequest <$> ghcjs_dom_xml_http_request_new

94+xmlHttpRequestGetUpload = getUpload

101

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

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

103− ghcjs_dom_xml_http_request_open ::

97+xmlHttpRequestGetResponseText = getResponseText

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

105

106−xmlHttpRequestOpen ::

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

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

109−xmlHttpRequestOpen self method url async user password

110− = ghcjs_dom_xml_http_request_open

111− (unXMLHttpRequest (toXMLHttpRequest self))

112− (toJSString method)

113− (toJSString url)

114− (toJSBool async)

115− (toJSString user)

116− (toJSString password)

117−

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

119− ghcjs_dom_xml_http_request_send ::

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

121−

122−xmlHttpRequestSend ::

123− (IsXMLHttpRequest self, ToJSString payload) =>

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

125−xmlHttpRequestSend self payload

126− = ghcjs_dom_xml_http_request_send

127− (unXMLHttpRequest (toXMLHttpRequest self))

128− (case payload of

129− Just p -> toJSString p

130− Nothing -> jsNull)

131−

132−

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

134− ghcjs_dom_xml_http_request_set_request_header ::

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

136−

137−xmlHttpRequestSetRequestHeader ::

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

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

140−xmlHttpRequestSetRequestHeader self header value

141− = ghcjs_dom_xml_http_request_set_request_header

142− (unXMLHttpRequest (toXMLHttpRequest self))

143− (toJSString header)

144− (toJSString value)

145−

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

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

148−

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

150−xmlHttpRequestAbort self

151− = ghcjs_dom_xml_http_request_abort

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

99+responseTextToText :: Maybe Text -> Maybe Text

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

100+responseTextToText = id

328

101

329−statusTextToText :: Text -> Text

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

330−statusTextToText = id

103+xmlHttpRequestGetResponseXML = getResponseXML

104+

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

106+xmlHttpRequestSetResponseType = setResponseType

331

107

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

108+toResponseType :: a -> a

355−toResponseType = toJSString

109+toResponseType = id

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

110

111+xmlHttpRequestGetResponseType :: XMLHttpRequest -> IO XMLHttpRequestResponseType

112+xmlHttpRequestGetResponseType = getResponseType

113+

114+xmlHttpRequestGetStatus :: XMLHttpRequest -> IO Word

115+xmlHttpRequestGetStatus = getStatus

116+

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

118+xmlHttpRequestGetStatusText = getStatusText

119+

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

121+xmlHttpRequestGetResponseURL = getResponseURL

122+

123+statusTextToText :: Text -> Text

124+statusTextToText = id

src/Reflex/Dom/Internal.hs+11−11

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

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

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

180mainWidget w = runWebGUI $ \webView -> do

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

182− Just body <- documentGetBody doc

182+ Just body <- getBody doc

183 attachWidget body webView w

184

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

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

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

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

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

189 attachWidget headElement webView h

190− Just body <- documentGetBody doc

190+ Just body <- getBody doc

191 attachWidget body webView b

192

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

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

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

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

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

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

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

198− Just body <- documentGetBody doc

198+ Just body <- getBody doc

199 attachWidget body webView w

200

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

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

245

246attachWidget :: (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

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

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

249 frames <- liftIO newChan

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

251 runWithActions dm = do

252 voidActionNeeded <- fireEventsAndRead dm $ do

253 sequence =<< readEvent voidActionHandle

254 runHostFrame $ runGui (sequence_ voidActionNeeded) guiEnv

255− Just df <- liftIO $ documentCreateDocumentFragment doc

255+ Just df <- createDocumentFragment doc

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

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

259 return (r, va)

260− liftIO $ htmlElementSetInnerHTML rootElement ""

260+ setInnerHTML rootElement $ Just ""

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

261+ _ <- appendChild rootElement $ Just df

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

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

src/Reflex/Dom/Widget/Basic.hs+144−147

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

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

22import GHCJS.DOM.Node

23import GHCJS.DOM.UIEvent

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

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

25import GHCJS.DOM.Document

26−import GHCJS.DOM.Element

26+import GHCJS.DOM.Element as E

27−import GHCJS.DOM.HTMLElement

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

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

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

29−import GHCJS.DOM.NamedNodeMap

29+import GHCJS.DOM.NamedNodeMap as NNM

30import Control.Lens hiding (element, children)

31import Data.These

32import Data.Align

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

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

62instance MonadIO m => Attributes m AttributeMap where

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

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

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

66 addAttributes attrs e = do

67 schedulePostBuild $ do

68 curAttrs <- sample $ current attrs

69− liftIO $ imapM_ (elementSetAttribute e) curAttrs

69+ imapM_ (setAttribute e) curAttrs

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

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

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

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

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

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

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

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

76buildEmptyElementNS mns elementTag attrs = do

77 doc <- askDocument

78 p <- askParent

79 Just e <- liftIO $ case mns of

80− Nothing -> documentCreateElement doc elementTag

80+ Nothing -> createElement doc (Just elementTag)

81− Just ns -> documentCreateElementNS doc ns elementTag

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

82 addAttributes attrs e

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

83+ _ <- appendChild p $ Just e

84 return $ castToElement e

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

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

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

97buildElement = buildElementNS Nothing

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

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

100namedNodeMapGetNames self = do

101− l <- namedNodeMapGetLength self

101+ l <- NNM.getLength self

102 let locations = if l == 0 then [] else [0..l-1] -- Can't use 0..l-1 if l is 0 because l is unsigned and will wrap around

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

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

104− Just n <- namedNodeMapItem self i

104+ Just n <- NNM.item self i

105− nodeGetNodeName n

105+ getNodeName n

106

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

108text = void . text'

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

112text' s = do

113 doc <- askDocument

114 p <- askParent

115− Just n <- liftIO $ documentCreateTextNode doc s

115+ Just n <- createTextNode doc s

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

116+ _ <- appendChild p $ Just n

117 return n

118

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

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

121 n <- text' ""

122 schedulePostBuild $ do

123 curS <- sample $ current s

124− liftIO $ nodeSetNodeValue n curS

124+ setNodeValue n $ Just curS

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

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

126

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

128display a = dynText =<< mapDyn show a

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

159 doc <- askDocument

160 runWidget <- getRunWidget

161 let build c = do

162− Just df <- liftIO $ documentCreateDocumentFragment doc

162+ Just df <- createDocumentFragment doc

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

164 runFrameWithTriggerRef newChildBuiltTriggerRef (result, voidActions)

165 postBuild

166− mp' <- liftIO $ nodeGetParentNode endPlaceholder

166+ mp' <- getParentNode endPlaceholder

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

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

168 return ()

169 addVoidAction $ ffor newChild $ \c -> do

170 liftIO $ deleteBetweenExclusive startPlaceholder endPlaceholder

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

209 Nothing -> Just Nothing -- Even if we let a Nothing through when the element doesn't already exist, this doesn't cause a problem because it is ignored

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

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

212− mkChild k v $ select childValChangedSelector $ Const2 k

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

213

214-- | Display the given map of items using the builder function provided, and update it with the given event. 'Nothing' entries will delete the corresponding children, and 'Just' entries will create or replace them. Since child events do not take any signal arguments, they are always rebuilt. To update a child without rebuilding, either embed signals in the map's values, or refer to them directly in the builder function.

215listHoldWithKey :: (Ord k, MonadWidget t m) => Map k v -> Event t (Map k (Maybe v)) -> (k -> v -> m a) -> m (Dynamic t (Map k a))

@@ -225,13 +225,13 @@ listHoldWithKey initialVals valsChanged mkChild = do

225 result <- mkChild k v

226 childEnd <- text' ""

227 return (result, (childStart, childEnd))

228− Just dfOrig <- liftIO $ documentCreateDocumentFragment doc

228+ Just dfOrig <- createDocumentFragment doc

229 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

230 stateRef <- liftIO $ newIORef initialState

231 children <- holdDyn initialState newChildren

232 addVoidAction $ switch $ fmap (mergeWith (>>) . map snd . Map.elems) $ current children

233− mpOrig <- liftIO $ nodeGetParentNode endPlaceholder

233+ mpOrig <- getParentNode endPlaceholder

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

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

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

236 curState <- liftIO $ readIORef stateRef

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

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

241 return Nothing

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

243 liftIO $ deleteBetweenExclusive start end

244− Just df <- liftIO $ documentCreateDocumentFragment doc

244+ Just df <- createDocumentFragment doc

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

246 let s = (childResult, childVoidAction)

247 modify (>>childPostBuild)

248− mp <- liftIO $ nodeGetParentNode end

248+ mp <- getParentNode end

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

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

250 return $ Just s

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

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

253− Just df <- liftIO $ documentCreateDocumentFragment doc

253+ Just df <- createDocumentFragment doc

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

255 let s = (childResult, childVoidAction)

256 modify (>>childPostBuild)

257 let placeholder = case Map.lookupGT k curState of

258 Nothing -> endPlaceholder

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

260− mp <- liftIO $ nodeGetParentNode placeholder

260+ mp <- getParentNode placeholder

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

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

262 return $ Just s

263 This state -> do -- No change

264 return $ Just state

@@ -304,40 +304,40 @@ selectViewListWithKey_ selection vals mkChild = liftM (fmap fst) $ selectViewLis

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

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

306deleteBetweenExclusive s e = do

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

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

308 case mCurrentParent of

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

310 Just currentParent -> do

311 let go = do

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

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

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

314− _ <- nodeRemoveChild currentParent $ Just x

314+ _ <- removeChild currentParent $ Just x

315 go

316 go

317

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

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

320deleteBetweenInclusive s e = do

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

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

322 case mCurrentParent of

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

324 Just currentParent -> do

325 let go = do

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

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

327− _ <- nodeRemoveChild currentParent $ Just x

327+ _ <- removeChild currentParent $ Just x

328 when (toNode s /= toNode x) go

329 go

330− _ <- nodeRemoveChild currentParent $ Just e

330+ _ <- removeChild currentParent $ Just e

331 return ()

332

333--------------------------------------------------------------------------------

334-- Adapters

335--------------------------------------------------------------------------------

336

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

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

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

339

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

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

341wrapDomEventMaybe element elementOnevent getValue = do

342 postGui <- askPostGui

343 runWithActions <- askRunWithActions

@@ -378,11 +378,11 @@ data EventTag

378 | MouseoutTag

379 | MouseoverTag

380 | MouseupTag

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

381+ | MousewheelTag

382 | ScrollTag

383 | SelectTag

384 | SubmitTag

385−-- | WheelTag -- See MousewheelTag

385+ | WheelTag

386 | BeforecutTag

387 | CutTag

388 | BeforecopyTag

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

426 Mouseout :: EventName 'MouseoutTag

427 Mouseover :: EventName 'MouseoverTag

428 Mouseup :: EventName 'MouseupTag

429− --Mousewheel :: EventName 'MousewheelTag

429+ Mousewheel :: EventName 'MousewheelTag

430 Scroll :: EventName 'ScrollTag

431 Select :: EventName 'SelectTag

432 Submit :: EventName 'SubmitTag

433− --Wheel :: EventName 'WheelTag

433+ Wheel :: EventName 'WheelTag

434 Beforecut :: EventName 'BeforecutTag

435 Cut :: EventName 'CutTag

436 Beforecopy :: EventName 'BeforecopyTag

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

447

448type family EventType en where

449 EventType 'AbortTag = UIEvent

450− EventType 'BlurTag = UIEvent

450+ EventType 'BlurTag = FocusEvent

451− EventType 'ChangeTag = UIEvent

451+ EventType 'ChangeTag = DOM.Event

452 EventType 'ClickTag = MouseEvent

453 EventType 'ContextmenuTag = MouseEvent

454 EventType 'DblclickTag = MouseEvent

@@ -460,87 +460,87 @@ type family EventType en where

460 EventType 'DragstartTag = MouseEvent

461 EventType 'DropTag = MouseEvent

462 EventType 'ErrorTag = UIEvent

463− EventType 'FocusTag = UIEvent

463+ EventType 'FocusTag = FocusEvent

464− EventType 'InputTag = UIEvent

464+ EventType 'InputTag = DOM.Event

465− EventType 'InvalidTag = UIEvent

465+ EventType 'InvalidTag = DOM.Event

466− EventType 'KeydownTag = UIEvent

466+ EventType 'KeydownTag = KeyboardEvent

467− EventType 'KeypressTag = UIEvent

467+ EventType 'KeypressTag = KeyboardEvent

468− EventType 'KeyupTag = UIEvent

468+ EventType 'KeyupTag = KeyboardEvent

469 EventType 'LoadTag = UIEvent

470 EventType 'MousedownTag = MouseEvent

471− EventType 'MouseenterTag = UIEvent

471+ EventType 'MouseenterTag = MouseEvent

472− EventType 'MouseleaveTag = UIEvent

472+ EventType 'MouseleaveTag = MouseEvent

473 EventType 'MousemoveTag = MouseEvent

474 EventType 'MouseoutTag = MouseEvent

475 EventType 'MouseoverTag = MouseEvent

476 EventType 'MouseupTag = MouseEvent

477− --EventType 'MousewheelTag = MouseEvent

477+ EventType 'MousewheelTag = MouseEvent

478 EventType 'ScrollTag = UIEvent

479 EventType 'SelectTag = UIEvent

480− EventType 'SubmitTag = UIEvent

480+ EventType 'SubmitTag = DOM.Event

481− --EventType 'WheelTag = UIEvent

481+ EventType 'WheelTag = WheelEvent

482− EventType 'BeforecutTag = UIEvent

482+ EventType 'BeforecutTag = DOM.Event

483− EventType 'CutTag = UIEvent

483+ EventType 'CutTag = DOM.Event

484− EventType 'BeforecopyTag = UIEvent

484+ EventType 'BeforecopyTag = DOM.Event

485− EventType 'CopyTag = UIEvent

485+ EventType 'CopyTag = DOM.Event

486− EventType 'BeforepasteTag = UIEvent

486+ EventType 'BeforepasteTag = DOM.Event

487− EventType 'PasteTag = UIEvent

487+ EventType 'PasteTag = DOM.Event

488− EventType 'ResetTag = UIEvent

488+ EventType 'ResetTag = DOM.Event

489− EventType 'SearchTag = UIEvent

489+ EventType 'SearchTag = DOM.Event

490− EventType 'SelectstartTag = UIEvent

490+ EventType 'SelectstartTag = DOM.Event

491− EventType 'TouchstartTag = UIEvent

491+ EventType 'TouchstartTag = TouchEvent

492− EventType 'TouchmoveTag = UIEvent

492+ EventType 'TouchmoveTag = TouchEvent

493− EventType 'TouchendTag = UIEvent

493+ EventType 'TouchendTag = TouchEvent

494− EventType 'TouchcancelTag = UIEvent

494+ EventType 'TouchcancelTag = TouchEvent

495−

495+

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

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

497−onEventName en = case en of

497+onEventName en e = case en of

498− Abort -> elementOnabort

498+ Abort -> on e E.abort

499− Blur -> elementOnblur

499+ Blur -> on e E.blurEvent

500− Change -> elementOnchange

500+ Change -> on e E.change

501− Click -> elementOnclick

501+ Click -> on e E.click

502− Contextmenu -> elementOncontextmenu

502+ Contextmenu -> on e E.contextMenu

503− Dblclick -> elementOndblclick

503+ Dblclick -> on e E.dblClick

504− Drag -> elementOndrag

504+ Drag -> on e E.drag

505− Dragend -> elementOndragend

505+ Dragend -> on e E.dragEnd

506− Dragenter -> elementOndragenter

506+ Dragenter -> on e E.dragEnter

507− Dragleave -> elementOndragleave

507+ Dragleave -> on e E.dragLeave

508− Dragover -> elementOndragover

508+ Dragover -> on e E.dragOver

509− Dragstart -> elementOndragstart

509+ Dragstart -> on e E.dragStart

510− Drop -> elementOndrop

510+ Drop -> on e E.drop

511− Error -> elementOnerror

511+ Error -> on e E.error

512− Focus -> elementOnfocus

512+ Focus -> on e E.focusEvent

513− Input -> elementOninput

513+ Input -> on e E.input

514− Invalid -> elementOninvalid

514+ Invalid -> on e E.invalid

515− Keydown -> elementOnkeydown

515+ Keydown -> on e E.keyDown

516− Keypress -> elementOnkeypress

516+ Keypress -> on e E.keyPress

517− Keyup -> elementOnkeyup

517+ Keyup -> on e E.keyUp

518− Load -> elementOnload

518+ Load -> on e E.load

519− Mousedown -> elementOnmousedown

519+ Mousedown -> on e E.mouseDown

520− Mouseenter -> elementOnmouseenter

520+ Mouseenter -> on e E.mouseEnter

521− Mouseleave -> elementOnmouseleave

521+ Mouseleave -> on e E.mouseLeave

522− Mousemove -> elementOnmousemove

522+ Mousemove -> on e E.mouseMove

523− Mouseout -> elementOnmouseout

523+ Mouseout -> on e E.mouseOut

524− Mouseover -> elementOnmouseover

524+ Mouseover -> on e E.mouseOver

525− Mouseup -> elementOnmouseup

525+ Mouseup -> on e E.mouseUp

526− --Mousewheel -> elementOnmousewheel

526+ Mousewheel -> on e E.mouseWheel

527− Scroll -> elementOnscroll

527+ Scroll -> on e E.scroll

528− Select -> elementOnselect

528+ Select -> on e E.select

529− Submit -> elementOnsubmit

529+ Submit -> on e E.submit

530− --Wheel -> elementOnwheel

530+ Wheel -> on e E.wheel

531− Beforecut -> elementOnbeforecut

531+ Beforecut -> on e E.beforeCut

532− Cut -> elementOncut

532+ Cut -> on e E.cut

533− Beforecopy -> elementOnbeforecopy

533+ Beforecopy -> on e E.beforeCopy

534− Copy -> elementOncopy

534+ Copy -> on e E.copy

535− Beforepaste -> elementOnbeforepaste

535+ Beforepaste -> on e E.beforePaste

536− Paste -> elementOnpaste

536+ Paste -> on e E.paste

537− Reset -> elementOnreset

537+ Reset -> on e E.reset

538− Search -> elementOnsearch

538+ Search -> on e E.search

539− Selectstart -> elementOnselectstart

539+ Selectstart -> on e E.selectStart

540− Touchstart -> elementOntouchstart

540+ Touchstart -> on e E.touchStart

541− Touchmove -> elementOntouchmove

541+ Touchmove -> on e E.touchMove

542− Touchend -> elementOntouchend

542+ Touchend -> on e E.touchEnd

543− Touchcancel -> elementOntouchcancel

543+ Touchcancel -> on e E.touchCancel

544

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

546

@@ -590,41 +590,40 @@ type family EventResultType (en :: EventTag) :: * where

590 EventResultType 'TouchendTag = ()

591 EventResultType 'TouchcancelTag = ()

592

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

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

594wrapDomEventsMaybe element handlers = do

595 postGui <- askPostGui

596 runWithActions <- askRunWithActions

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

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

598+ unsubscribe <- onEventName en element $ do

599 mv <- handlers en

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

601 return $ liftIO $ do

602 unsubscribe

603 return $! e

604

605−getKeyEvent :: EventM UIEvent e Int

605+getKeyEvent :: EventM e KeyboardEvent Int

606getKeyEvent = do

607 e <- event

608− liftIO $ do

608+ which <- getWhich e

609− which <- uiEventGetWhich e

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

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

611− charCode <- uiEventGetCharCode e

610+ charCode <- getCharCode e

612− if charCode /= 0 then return charCode else

611+ if charCode /= 0 then return charCode else

613− uiEventGetKeyCode e

612+ getKeyCode e

614−

613+

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

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

616getMouseEventCoords = do

615getMouseEventCoords = do

617 e <- event

616 e <- event

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

617+ bisequence (getX e, getY e)

619

618

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

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

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

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

622 Click -> return ()

621 Click -> return ()

623 Dblclick -> return ()

622 Dblclick -> return ()

624 Keypress -> getKeyEvent

623 Keypress -> getKeyEvent

624+ Scroll -> getScrollTop e

625 Keydown -> getKeyEvent

626 Keyup -> getKeyEvent

627− Scroll -> liftIO $ elementGetScrollTop e

628 Mousemove -> getMouseEventCoords

627 Mousemove -> getMouseEventCoords

629 Mouseup -> getMouseEventCoords

628 Mouseup -> getMouseEventCoords

630 Mousedown -> getMouseEventCoords

629 Mousedown -> getMouseEventCoords

@@ -664,7 +663,7 @@ defaultDomEventHandler e evt = liftM (Just . EventResult) $ case evt of

664 Touchend -> return ()

663 Touchend -> return ()

665 Touchcancel -> return ()

664 Touchcancel -> return ()

666

665

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

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 Element (EventType en) (Maybe (EventResult en))) -> Element -> m (El t)

668wrapElement eh e = do

667wrapElement eh e = do

669 es <- wrapDomEventsMaybe e $ eh e

668 es <- wrapDomEventsMaybe e $ eh e

670 return $ El e es

669 return $ El e es

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

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

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

750elDynHtml' elementTag html = do

749elDynHtml' elementTag html = do

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

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

752− let h = castToHTMLElement e

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

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

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

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

755 wrapElement defaultDomEventHandler e

753 wrapElement defaultDomEventHandler e

756

754

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

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

758elDynHtmlAttr' elementTag attrs html = do

756elDynHtmlAttr' elementTag attrs html = do

759 e <- buildEmptyElement elementTag attrs

757 e <- buildEmptyElement elementTag attrs

760− let h = castToHTMLElement e

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

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

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

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

763 wrapElement defaultDomEventHandler e

760 wrapElement defaultDomEventHandler e

764

761

765data Link t

762data Link t

@@ -784,7 +781,7 @@ class HasDomEvent t a where

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

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

785

782

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

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

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

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

788

785

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

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

790linkClass s c = do

787linkClass s c = do

@@ -859,7 +856,7 @@ tabDisplay ulClass activeClass tabItems = do

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

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

860 dAttrs <- mapDyn (\sel -> do

857 dAttrs <- mapDyn (\sel -> do

861 let t1 = listToMaybe $ Map.keys tabItems

858 let t1 = listToMaybe $ Map.keys tabItems

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

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

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

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

864 return ()

861 return ()

865 where

862 where

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

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

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

875unsafePlaceElement e = do

872unsafePlaceElement e = do

876 p <- askParent

873 p <- askParent

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

874+ _ <- appendChild p $ Just e

878 wrapElement defaultDomEventHandler e

875 wrapElement defaultDomEventHandler e

879

876

880deriveGEq ''EventName

877deriveGEq ''EventName

src/Reflex/Dom/Widget/Input.hs+32−33

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

9import Reflex

10import Reflex.Host.Class

11−import GHCJS.DOM.HTMLInputElement

11+import GHCJS.DOM.HTMLInputElement as Input

12−import GHCJS.DOM.HTMLTextAreaElement

12+import GHCJS.DOM.HTMLTextAreaElement as TextArea

13−import GHCJS.DOM.Element

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

14−import GHCJS.DOM.HTMLSelectElement

14+import GHCJS.DOM.HTMLSelectElement as Select

15import GHCJS.DOM.EventM

16import GHCJS.DOM.File

17−import GHCJS.DOM.FileList

17+import qualified GHCJS.DOM.FileList as FileList

18import Data.Monoid

19import Data.Map as Map

20import Control.Lens

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

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

54textInput (TextInputConfig inputType initial eSetValue dAttrs) = do

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

56− liftIO $ htmlInputElementSetValue e initial

56+ Input.setValue e $ Just initial

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

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

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

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

59 postGui <- askPostGui

60 runWithActions <- askRunWithActions

61 eChangeFocus <- newEventWithTrigger $ \eChangeFocusTrigger -> do

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

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

63 postGui $ runWithActions [eChangeFocusTrigger :=> False]

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

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

65 postGui $ runWithActions [eChangeFocusTrigger :=> True]

66 return $ liftIO $ unsubscribeOnblur >> unsubscribeOnfocus

67 dFocus <- holdDyn False eChangeFocus

68− eKeypress <- wrapDomEvent e elementOnkeypress getKeyEvent

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

69− eKeydown <- wrapDomEvent e elementOnkeydown getKeyEvent

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

70− eKeyup <- wrapDomEvent e elementOnkeyup getKeyEvent

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

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

72 return $ TextInput dValue eChange eKeypress eKeydown eKeyup dFocus e

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

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

98textArea (TextAreaConfig initial eSet attrs) = do

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

100− liftIO $ htmlTextAreaElementSetValue e initial

100+ TextArea.setValue e $ Just initial

101 postGui <- askPostGui

102 runWithActions <- askRunWithActions

103 eChangeFocus <- newEventWithTrigger $ \eChangeFocusTrigger -> do

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

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

105 postGui $ runWithActions [eChangeFocusTrigger :=> False]

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

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

107 postGui $ runWithActions [eChangeFocusTrigger :=> True]

108 return $ liftIO $ unsubscribeOnblur >> unsubscribeOnfocus

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

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

110 f <- holdDyn False eChangeFocus

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

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

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

113− eKeypress <- wrapDomEvent e elementOnkeypress getKeyEvent

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

114 return $ TextArea v ev e f eKeypress

115

116data CheckboxConfig t

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

135checkbox checked config = do

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

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

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

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

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

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

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

141 return $ Checkbox dValue eClick

142

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

144checkboxView dAttrs dValue = do

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

146− eClicked <- wrapDomEvent e elementOnclick $ do

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

147 preventDefault

148− liftIO $ htmlInputElementGetChecked e

148+ Input.getChecked e

149 schedulePostBuild $ do

150 v <- sample $ current dValue

151− when v $ liftIO $ htmlInputElementSetChecked e True

151+ when v $ Input.setChecked e True

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

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

153 return eClicked

154

155data FileInput t

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

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

169fileInput (FileInputConfig dAttrs) = do

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

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

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

172− Just files <- htmlInputElementGetFiles e

172+ Just files <- getFiles e

173− len <- fileListGetLength files

173+ len <- FileList.getLength files

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

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

175 dValue <- holdDyn [] eChange

176 return $ FileInput dValue e

177

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

201 listWithKey optionsWithDefault $ \k v -> do

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

203 let e = castToHTMLSelectElement $ _el_element eRaw

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

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

205− eChange <- wrapDomEvent e elementOnchange $ do

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

206− kStr <- liftIO $ htmlSelectElementGetValue e

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

207 return $ readMay kStr

208 let readKey opts mk = fromMaybe k0 $ do

209 k <- mk

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

320instance HasStateModeWitness View where

321 stateModeWitness = ViewWitness

322-}

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+18−17

@@ -9,6 +9,7 @@ import Control.Monad

9import Control.Monad.IO.Class

10import Data.Monoid

11import GHCJS.DOM.Element

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+1−1

@@ -49,7 +49,7 @@ data XhrRequestConfig

49 = XhrRequestConfig { _xhrRequestConfig_headers :: Map String String

50 , _xhrRequestConfig_user :: Maybe String

51 , _xhrRequestConfig_password :: Maybe String

52− , _xhrRequestConfig_responseType :: Maybe String

52+ , _xhrRequestConfig_responseType :: Maybe XMLHttpRequestResponseType

53 , _xhrRequestConfig_sendData :: Maybe String

54 }

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