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

* webSocketSend is not implemented yet # Conflicts: # reflex-dom.cabal # src-ghcjs/Reflex/Dom/Xhr/Foreign.hs # src/Reflex/Dom/Widget/Lazy.hs

commit31d6ed49d00f93ea7962ba329c1ce9940f251c9f authorRyan Trinkle <ryan.trinkle@gmail.com> dateFri 20 Nov 2015, 21:14 (11 years ago) parent21b7c7e
12 files changed+348−593
compare with develop
unifiedsplit
reflex-dom.cabal+6−7 src-ghc/Reflex/Dom/Internal/Foreign.hs+3−3 src-ghc/Reflex/Dom/Xhr/Foreign.hs+17−3 src-ghcjs/Reflex/Dom/Internal/Foreign.hs−6 src-ghcjs/Reflex/Dom/WebSocket/Foreign.hs+26 src-ghcjs/Reflex/Dom/Xhr/Foreign.hs+88−363 src/Reflex/Dom/Internal.hs+11−11 src/Reflex/Dom/Widget/Basic.hs+144−147 src/Reflex/Dom/Widget/Input.hs+32−33 src/Reflex/Dom/Widget/Lazy.hs+2−2 src/Reflex/Dom/Widget/Resize.hs+18−17 src/Reflex/Dom/Xhr.hs+1−1
reflex-dom.cabal+6−7
@@ -23,14 +23,14 @@ library
2323 reflex == 0.3.*,
2424 dependent-sum == 0.2.*,
2525 dependent-map == 0.1.*,
26− semigroups == 0.16.*,
26+ semigroups >= 0.16 && < 0.18,
2727 mtl >= 2.1 && < 2.3,
2828 containers == 0.5.*,
2929 these >= 0.4 && < 0.7,
3030 ref-tf == 0.4.*,
31+ ghcjs-dom >= 0.2.1 && < 0.3,
3132 transformers == 0.3.* || == 0.4.*,
3233 lens >= 4.7 && < 4.14,
33− ghcjs-dom >= 0.1.1.3 && < 0.2,
3434 safe == 0.3.*,
3535 text == 1.2.*,
3636 bytestring == 0.10.*,
@@ -40,19 +40,18 @@ library
4040 exception-transformers == 0.4.*,
4141 directory == 1.2.*,
4242 dependent-sum-template >= 0.0.0.4 && < 0.1,
43− bifunctors >= 4.2 && < 5.1
43+ bifunctors >= 4.2 && < 6
4444
4545 if impl(ghcjs)
4646 hs-source-dirs: src-ghcjs
47− cpp-options: -D__GHCJS__
4847 build-depends:
4948 ghcjs-base
5049 else
5150 hs-source-dirs: src-ghc
5251 build-depends:
5352 glib == 0.13.*,
54− gtk3 == 0.13.*,
55− webkitgtk3 == 0.13.*,
53+ gtk3 >= 0.13.0 && < 0.15,
54+ webkitgtk3 == 0.14.*,
5655 webkitgtk3-javascriptcore == 0.13.*
5756
5857 exposed-modules:
@@ -73,7 +72,7 @@ library
7372 Reflex.Dom.Xhr.Foreign
7473
7574 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
7776
7877source-repository head
7978 type: git
src-ghc/Reflex/Dom/Internal/Foreign.hs+3−3
@@ -7,7 +7,7 @@ import Control.Concurrent
77import Control.Monad.State.Strict hiding (mapM, mapM_, forM, forM_, sequence, sequence_, get)
88import Foreign.Ptr
99import GHCJS.DOM.Navigator
10−import GHCJS.DOM.DOMWindow
10+import GHCJS.DOM.Window
1111import Graphics.UI.Gtk hiding (Widget)
1212import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSBase
1313import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSObjectRef
@@ -69,8 +69,8 @@ runWebGUI' userAgentKey main = do
6969 case mbWindow of
7070 Just window -> do
7171 -- Check if we are running in javascript inside the the native version
72− Just n <- domWindowGetNavigator window
73− agent <- navigatorGetUserAgent n
72+ Just n <- getNavigator window
73+ agent <- getUserAgent n
7474 unless ((" " ++ userAgentKey) `isSuffixOf` agent) $ main (castToWebView window)
7575 Nothing -> do
7676 makeDefaultWebView userAgentKey main
src-ghc/Reflex/Dom/Xhr/Foreign.hs+17−3
@@ -4,6 +4,7 @@ module Reflex.Dom.Xhr.Foreign where
44import Control.Lens.Indexed
55import qualified Data.Text as T
66import Data.Text (Text)
7+import Data.Typeable (Typeable)
78import System.Glib.FFI
89import Graphics.UI.Gtk.WebKit.WebView
910import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSBase
@@ -29,8 +30,21 @@ statusTextToText = T.pack
2930stringToJSValue :: JSContextRef -> String -> IO JSValueRef
3031stringToJSValue ctx s = jsvaluemakestring ctx =<< jsstringcreatewithutf8cstring s
3132
32−toResponseType :: a -> a
33−toResponseType = id
33+data XMLHttpRequestResponseType = XMLHttpRequestResponseType
34+ | XMLHttpRequestResponseTypeArraybuffer
35+ | XMLHttpRequestResponseTypeBlob
36+ | XMLHttpRequestResponseTypeDocument
37+ | XMLHttpRequestResponseTypeJson
38+ | XMLHttpRequestResponseTypeText
39+ deriving (Show, Read, Eq, Ord, Typeable)
40+
41+toResponseType :: XMLHttpRequestResponseType -> String
42+toResponseType XMLHttpRequestResponseType = ""
43+toResponseType XMLHttpRequestResponseTypeArraybuffer = "arraybuffer"
44+toResponseType XMLHttpRequestResponseTypeBlob = "blob"
45+toResponseType XMLHttpRequestResponseTypeDocument = "document"
46+toResponseType XMLHttpRequestResponseTypeJson = "json"
47+toResponseType XMLHttpRequestResponseTypeText = "text"
3448
3549xmlHttpRequestNew :: WebView -> IO XMLHttpRequest
3650xmlHttpRequestNew wv = do
@@ -105,7 +119,7 @@ xmlHttpRequestSend xhr payload = do
105119 return (o,s)
106120 _ <- jsevaluatescript c s o nullPtr 1 nullPtr
107121 return ()
108−
122+
109123xmlHttpRequestSetRequestHeader :: XMLHttpRequest -> String -> String -> IO ()
110124xmlHttpRequestSetRequestHeader xhr header value = do
111125 let c = xhrContext xhr
src-ghcjs/Reflex/Dom/Internal/Foreign.hs−6
@@ -1,9 +1,3 @@
11module Reflex.Dom.Internal.Foreign (runWebGUI) where
22
33import 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
1111import Foreign.Ptr
1212import GHCJS.Foreign
1313import 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
1422
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+{-
1540#define JS(name, js, type) foreign import javascript unsafe js name :: type
1641
1742newtype JSWebSocket = JSWebSocket { unWebSocket :: JSRef JSWebSocket }
@@ -47,3 +72,4 @@ newWebSocket _ url onMessage onClose = do
4772 onClose
4873 liftM JSWebSocket $ newWebSocket_ (toJSString url) onMessageFun onCloseFun
4974
75+-}
src-ghcjs/Reflex/Dom/Xhr/Foreign.hs+88−363
@@ -1,399 +1,124 @@
1−{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI #-}
1+{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI, OverloadedStrings #-}
22
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
48
5−import GHCJS.Types
6−import GHCJS.Foreign
7−import GHCJS.Marshal
8−import qualified Data.Text as T
9+import Prelude hiding (error)
910import Data.Text (Text)
10−import Data.Word
1111import GHCJS.DOM.Types hiding (Text)
12−import Control.Applicative ((<$>))
13−import GHCJS.DOM.EventM
1412import 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)
1618
1719prepareWebView :: WebView -> IO ()
1820prepareWebView _ = return ()
1921
20−foreign import javascript unsafe "h$isInstanceOf $1 $2"
21− typeInstanceIsA' :: JSRef a -> JSRef GType -> Bool
22+xmlHttpRequestNew :: a -> IO XMLHttpRequest
23+xmlHttpRequestNew _ = newXMLHttpRequest -- XMLHttpRequest <$> ghcjs_dom_xml_http_request_new
2224
23−typeInstanceIsA :: JSRef a -> GType -> Bool
24−typeInstanceIsA o (GType t) = typeInstanceIsA' o t
25+xmlHttpRequestOpen ::
26+ (ToJSString method, ToJSString url, ToJSString user, ToJSString password) =>
27+ XMLHttpRequest -> method -> url -> Bool -> user -> password -> IO ()
28+xmlHttpRequestOpen = open
2529
26−castTo :: (GObjectClass obj, GObjectClass obj') => GType -> String
27− -> (obj -> obj')
28−castTo gtype objTypeName obj =
29− case toGObject obj of
30− gobj@(GObject objRef)
31− | typeInstanceIsA objRef gtype
32− -> unsafeCastGObject gobj
33− | otherwise -> error $ "Cannot cast object to " ++ objTypeName
30+-- This used to be a non blocking call, but now it uses an interruptible ffi
31+xmlHttpRequestSend :: ToJSString payload => XMLHttpRequest -> Maybe payload -> IO ()
32+xmlHttpRequestSend self = maybe (send self) (sendString self)
3433
34+xmlHttpRequestSetRequestHeader :: (ToJSString header, ToJSString value)
35+ => XMLHttpRequest -> header -> value -> IO ()
36+xmlHttpRequestSetRequestHeader = setRequestHeader
3537
36−newtype XMLHttpRequest = XMLHttpRequest { unXMLHttpRequest :: JSRef XMLHttpRequest }
38+xmlHttpRequestAbort :: XMLHttpRequest -> IO ()
39+xmlHttpRequestAbort = abort
3740
38−instance Eq XMLHttpRequest where
39− (==) = eqRef `on` unXMLHttpRequest
41+xmlHttpRequestGetAllResponseHeaders :: XMLHttpRequest -> IO Text
42+xmlHttpRequestGetAllResponseHeaders self = fromMaybe "" <$> getAllResponseHeaders self
4043
41−instance ToJSRef XMLHttpRequest where
42− toJSRef = return . unXMLHttpRequest
43− {-# INLINE toJSRef #-}
44+xmlHttpRequestGetResponseHeader :: (ToJSString header)
45+ => XMLHttpRequest -> header -> IO Text
46+xmlHttpRequestGetResponseHeader self header = fromMaybe "" <$> getResponseHeader self header
4447
45−instance FromJSRef XMLHttpRequest where
46− fromJSRef = return . fmap XMLHttpRequest . maybeJSNull
47− {-# INLINE fromJSRef #-}
48+xmlHttpRequestOverrideMimeType :: ToJSString override => XMLHttpRequest -> override -> IO ()
49+xmlHttpRequestOverrideMimeType = overrideMimeType
4850
49−class GObjectClass o => IsXMLHttpRequest o
50−toXMLHttpRequest :: IsXMLHttpRequest o => o -> XMLHttpRequest
51−toXMLHttpRequest = unsafeCastGObject . toGObject
51+xmlHttpRequestDispatchEvent :: IsEvent evt => XMLHttpRequest -> Maybe evt -> IO Bool
52+xmlHttpRequestDispatchEvent = dispatchEvent
5253
53−instance IsXMLHttpRequest XMLHttpRequest
54−instance GObjectClass XMLHttpRequest where
55− toGObject = GObject . castRef . unXMLHttpRequest
56− unsafeCastGObject = XMLHttpRequest . castRef . unGObject
54+xmlHttpRequestOnabort :: XMLHttpRequest -> EventM XMLHttpRequest XMLHttpRequestProgressEvent () -> IO (IO ())
55+xmlHttpRequestOnabort = (`on` abortEvent)
5756
58−castToXMLHttpRequest :: GObjectClass obj => obj -> XMLHttpRequest
59−castToXMLHttpRequest = castTo gTypeXMLHttpRequest "XMLHttpRequest"
57+xmlHttpRequestOnerror :: XMLHttpRequest -> EventM XMLHttpRequest XMLHttpRequestProgressEvent () -> IO (IO ())
58+xmlHttpRequestOnerror = (`on` error)
6059
61−foreign import javascript unsafe "window[\"XMLHttpRequest\"]" gTypeXMLHttpRequest' :: JSRef GType
62−gTypeXMLHttpRequest :: GType
63−gTypeXMLHttpRequest = GType gTypeXMLHttpRequest'
60+xmlHttpRequestOnload :: XMLHttpRequest -> EventM XMLHttpRequest XMLHttpRequestProgressEvent () -> IO (IO ())
61+xmlHttpRequestOnload = (`on` load)
6462
63+xmlHttpRequestOnloadend :: XMLHttpRequest -> EventM XMLHttpRequest ProgressEvent () -> IO (IO ())
64+xmlHttpRequestOnloadend = (`on` loadEnd)
6565
66−newtype XMLHttpRequestUpload = XMLHttpRequestUpload { unXMLHttpRequestUpload :: JSRef XMLHttpRequestUpload }
66+xmlHttpRequestOnloadstart :: XMLHttpRequest -> EventM XMLHttpRequest ProgressEvent () -> IO (IO ())
67+xmlHttpRequestOnloadstart = (`on` loadStart)
6768
68−instance Eq XMLHttpRequestUpload where
69− (==) = eqRef `on` unXMLHttpRequestUpload
69+xmlHttpRequestOnprogress :: XMLHttpRequest -> EventM XMLHttpRequest XMLHttpRequestProgressEvent () -> IO (IO ())
70+xmlHttpRequestOnprogress = (`on` progress)
7071
71−instance ToJSRef XMLHttpRequestUpload where
72− toJSRef = return . unXMLHttpRequestUpload
73− {-# INLINE toJSRef #-}
72+xmlHttpRequestOntimeout :: XMLHttpRequest -> EventM XMLHttpRequest ProgressEvent () -> IO (IO ())
73+xmlHttpRequestOntimeout = (`on` timeout)
7474
75−instance FromJSRef XMLHttpRequestUpload where
76− fromJSRef = return . fmap XMLHttpRequestUpload . maybeJSNull
77− {-# INLINE fromJSRef #-}
75+xmlHttpRequestOnreadystatechange :: XMLHttpRequest -> EventM XMLHttpRequest Event () -> IO (IO ())
76+xmlHttpRequestOnreadystatechange = (`on` readyStateChange)
7877
79−class GObjectClass o => IsXMLHttpRequestUpload o
80−toXMLHttpRequestUpload :: IsXMLHttpRequestUpload o => o -> XMLHttpRequestUpload
81−toXMLHttpRequestUpload = unsafeCastGObject . toGObject
78+xmlHttpRequestSetTimeout :: XMLHttpRequest -> Word -> IO ()
79+xmlHttpRequestSetTimeout = setTimeout
8280
83−instance IsXMLHttpRequestUpload XMLHttpRequestUpload
84−instance GObjectClass XMLHttpRequestUpload where
85− toGObject = GObject . castRef . unXMLHttpRequestUpload
86− unsafeCastGObject = XMLHttpRequestUpload . castRef . unGObject
81+xmlHttpRequestGetTimeout :: XMLHttpRequest -> IO Word
82+xmlHttpRequestGetTimeout = getTimeout
8783
88−castToXMLHttpRequestUpload :: GObjectClass obj => obj -> XMLHttpRequestUpload
89−castToXMLHttpRequestUpload = castTo gTypeXMLHttpRequestUpload "XMLHttpRequestUpload"
84+xmlHttpRequestGetReadyState :: XMLHttpRequest -> IO Word
85+xmlHttpRequestGetReadyState = getReadyState
9086
91−foreign import javascript unsafe "window[\"XMLHttpRequestUpload\"]" gTypeXMLHttpRequestUpload' :: JSRef GType
92−gTypeXMLHttpRequestUpload :: GType
93−gTypeXMLHttpRequestUpload = GType gTypeXMLHttpRequestUpload'
87+xmlHttpRequestSetWithCredentials :: XMLHttpRequest -> Bool -> IO ()
88+xmlHttpRequestSetWithCredentials = setWithCredentials
9489
95−foreign import javascript unsafe "new XMLHttpRequest()"
96− ghcjs_dom_xml_http_request_new ::
97− IO (JSRef XMLHttpRequest)
90+xmlHttpRequestGetWithCredentials :: XMLHttpRequest -> IO Bool
91+xmlHttpRequestGetWithCredentials = getWithCredentials
9892
99−xmlHttpRequestNew :: a -> IO XMLHttpRequest
100−xmlHttpRequestNew _ = XMLHttpRequest <$> ghcjs_dom_xml_http_request_new
93+xmlHttpRequestGetUpload :: XMLHttpRequest -> IO (Maybe XMLHttpRequestUpload)
94+xmlHttpRequestGetUpload = getUpload
10195
102−foreign import javascript unsafe "$1[\"open\"]($2, $3, $4, $5, $6)"
103− ghcjs_dom_xml_http_request_open ::
104− JSRef XMLHttpRequest -> JSString -> JSString -> JSBool -> JSString -> JSString -> IO ()
96+xmlHttpRequestGetResponseText :: FromJSString result => XMLHttpRequest -> IO (Maybe result)
97+xmlHttpRequestGetResponseText = getResponseText
10598
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
327−responseTextToText r = fmap (T.pack . fromJSString) r
99+responseTextToText :: Maybe Text -> Maybe Text
100+responseTextToText = id
328101
329−statusTextToText :: Text -> Text
330−statusTextToText = id
102+xmlHttpRequestGetResponseXML :: XMLHttpRequest -> IO (Maybe Document)
103+xmlHttpRequestGetResponseXML = getResponseXML
104+
105+xmlHttpRequestSetResponseType :: XMLHttpRequest -> XMLHttpRequestResponseType -> IO ()
106+xmlHttpRequestSetResponseType = setResponseType
331107
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)))
108+toResponseType :: a -> a
109+toResponseType = id
399110
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
99import GHCJS.DOM hiding (runWebGUI)
1010import GHCJS.DOM.Types hiding (Widget, unWidget, Event)
1111import GHCJS.DOM.Node
12−import GHCJS.DOM.HTMLElement
12+import GHCJS.DOM.Element
1313import GHCJS.DOM.Document
1414import Reflex.Class
1515import Reflex.Host.Class
@@ -179,23 +179,23 @@ holdOnStartup a0 ma = do
179179mainWidget :: Widget Spider (Gui Spider (WithWebView SpiderHost) (HostFrame Spider)) () -> IO ()
180180mainWidget w = runWebGUI $ \webView -> do
181181 Just doc <- liftM (fmap castToHTMLDocument) $ webViewGetDomDocument webView
182− Just body <- documentGetBody doc
182+ Just body <- getBody doc
183183 attachWidget body webView w
184184
185185mainWidgetWithHead :: Widget Spider (Gui Spider (WithWebView SpiderHost) (HostFrame Spider)) () -> Widget Spider (Gui Spider (WithWebView SpiderHost) (HostFrame Spider)) () -> IO ()
186186mainWidgetWithHead h b = runWebGUI $ \webView -> do
187187 Just doc <- liftM (fmap castToHTMLDocument) $ webViewGetDomDocument webView
188− Just headElement <- liftM (fmap castToHTMLElement) $ documentGetHead doc
188+ Just headElement <- liftM (fmap castToHTMLElement) $ getHead doc
189189 attachWidget headElement webView h
190− Just body <- documentGetBody doc
190+ Just body <- getBody doc
191191 attachWidget body webView b
192192
193193mainWidgetWithCss :: ByteString -> Widget Spider (Gui Spider (WithWebView SpiderHost) (HostFrame Spider)) () -> IO ()
194194mainWidgetWithCss css w = runWebGUI $ \webView -> do
195195 Just doc <- liftM (fmap castToHTMLDocument) $ webViewGetDomDocument webView
196− Just headElement <- liftM (fmap castToHTMLElement) $ documentGetHead doc
197− htmlElementSetInnerHTML headElement $ "<style>" <> T.unpack (decodeUtf8 css) <> "</style>" --TODO: Fix this
198− Just body <- documentGetBody doc
196+ Just headElement <- liftM (fmap castToHTMLElement) $ getHead doc
197+ setInnerHTML headElement . Just $ "<style>" <> T.unpack (decodeUtf8 css) <> "</style>" --TODO: Fix this
198+ Just body <- getBody doc
199199 attachWidget body webView w
200200
201201newtype WithWebView m a = WithWebView { unWithWebView :: ReaderT WebView m a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadException, MonadAsyncException)
@@ -245,20 +245,20 @@ runWithWebView = runReaderT . unWithWebView
245245
246246attachWidget :: (IsHTMLElement e) => e -> WebView -> Widget Spider (Gui Spider (WithWebView SpiderHost) (HostFrame Spider)) a -> IO a
247247attachWidget 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
249249 frames <- liftIO newChan
250250 rec let guiEnv = GuiEnv doc (writeChan frames . runSpiderHost . flip runWithWebView wv) runWithActions wv :: GuiEnv Spider (WithWebView SpiderHost)
251251 runWithActions dm = do
252252 voidActionNeeded <- fireEventsAndRead dm $ do
253253 sequence =<< readEvent voidActionHandle
254254 runHostFrame $ runGui (sequence_ voidActionNeeded) guiEnv
255− Just df <- liftIO $ documentCreateDocumentFragment doc
255+ Just df <- createDocumentFragment doc
256256 (result, voidAction) <- runHostFrame $ flip runGui guiEnv $ do
257257 (r, postBuild, va) <- runWidget df w
258258 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
259259 return (r, va)
260− liftIO $ htmlElementSetInnerHTML rootElement ""
261− _ <- liftIO $ nodeAppendChild rootElement $ Just df
260+ setInnerHTML rootElement $ Just ""
261+ _ <- appendChild rootElement $ Just df
262262 voidActionHandle <- subscribeEvent voidAction --TODO: Should be unnecessary
263263 --postGUISync seems to leak memory on GHC (unknown on GHCJS)
264264 _ <- 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
2121import Control.Monad.State hiding (state, mapM, mapM_, forM, forM_, sequence, sequence_)
2222import GHCJS.DOM.Node
2323import GHCJS.DOM.UIEvent
24−import GHCJS.DOM.EventM (event, EventM, stopPropagation)
24+import GHCJS.DOM.EventM (on, event, EventM, stopPropagation)
2525import GHCJS.DOM.Document
26−import GHCJS.DOM.Element
27−import GHCJS.DOM.HTMLElement
28−import GHCJS.DOM.Types hiding (Widget (..), unWidget, Event)
29−import GHCJS.DOM.NamedNodeMap
26+import GHCJS.DOM.Element as E
27+import GHCJS.DOM.Types hiding (Event)
28+import qualified GHCJS.DOM.Types as DOM (Event)
29+import GHCJS.DOM.NamedNodeMap as NNM
3030import Control.Lens hiding (element, children)
3131import Data.These
3232import Data.Align
@@ -60,27 +60,27 @@ class Attributes m a where
6060 addAttributes :: IsElement e => a -> e -> m ()
6161
6262instance MonadIO m => Attributes m AttributeMap where
63− addAttributes curAttrs e = liftIO $ imapM_ (elementSetAttribute e) curAttrs
63+ addAttributes curAttrs e = imapM_ (setAttribute e) curAttrs
6464
6565instance MonadWidget t m => Attributes m (Dynamic t AttributeMap) where
6666 addAttributes attrs e = do
6767 schedulePostBuild $ do
6868 curAttrs <- sample $ current attrs
69− liftIO $ imapM_ (elementSetAttribute e) curAttrs
69+ imapM_ (setAttribute e) curAttrs
7070 addVoidAction $ flip fmap (updated attrs) $ \newAttrs -> liftIO $ do
71− oldAttrs <- maybe (return Set.empty) namedNodeMapGetNames =<< elementGetAttributes e
72− forM_ (Set.toList $ oldAttrs `Set.difference` Map.keysSet newAttrs) $ elementRemoveAttribute e
73− imapM_ (elementSetAttribute e) newAttrs --TODO: avoid re-setting unchanged attributes; possibly do the compare using Align in haskell
71+ oldAttrs <- maybe (return Set.empty) namedNodeMapGetNames =<< getAttributes e
72+ forM_ (Set.toList $ oldAttrs `Set.difference` Map.keysSet newAttrs) $ removeAttribute e
73+ imapM_ (setAttribute e) newAttrs --TODO: avoid re-setting unchanged attributes; possibly do the compare using Align in haskell
7474
7575buildEmptyElementNS :: (MonadWidget t m, Attributes m attrs) => Maybe String -> String -> attrs -> m Element
7676buildEmptyElementNS mns elementTag attrs = do
7777 doc <- askDocument
7878 p <- askParent
7979 Just e <- liftIO $ case mns of
80− Nothing -> documentCreateElement doc elementTag
81− Just ns -> documentCreateElementNS doc ns elementTag
80+ Nothing -> createElement doc (Just elementTag)
81+ Just ns -> createElementNS doc (Just ns) (Just elementTag)
8282 addAttributes attrs e
83− _ <- liftIO $ nodeAppendChild p $ Just e
83+ _ <- appendChild p $ Just e
8484 return $ castToElement e
8585
8686buildEmptyElement :: (MonadWidget t m, Attributes m attrs) => String -> attrs -> m Element
@@ -96,13 +96,13 @@ buildElementNS mns elementTag attrs child = do
9696buildElement :: (MonadWidget t m, Attributes m attrs) => String -> attrs -> m a -> m (Element, a)
9797buildElement = buildElementNS Nothing
9898
99−namedNodeMapGetNames :: IsNamedNodeMap self => self -> IO (Set String)
99+namedNodeMapGetNames :: NamedNodeMap -> IO (Set String)
100100namedNodeMapGetNames self = do
101− l <- namedNodeMapGetLength self
101+ l <- NNM.getLength self
102102 let locations = if l == 0 then [] else [0..l-1] -- Can't use 0..l-1 if l is 0 because l is unsigned and will wrap around
103− liftM Set.fromList $ forM locations $ \i -> do
104− Just n <- namedNodeMapItem self i
105− nodeGetNodeName n
103+ liftM (Set.fromList . catMaybes) $ forM locations $ \i -> do
104+ Just n <- NNM.item self i
105+ getNodeName n
106106
107107text :: MonadWidget t m => String -> m ()
108108text = void . text'
@@ -112,8 +112,8 @@ text' :: MonadWidget t m => String -> m Text
112112text' s = do
113113 doc <- askDocument
114114 p <- askParent
115− Just n <- liftIO $ documentCreateTextNode doc s
116− _ <- liftIO $ nodeAppendChild p $ Just n
115+ Just n <- createTextNode doc s
116+ _ <- appendChild p $ Just n
117117 return n
118118
119119dynText :: MonadWidget t m => Dynamic t String -> m ()
@@ -121,8 +121,8 @@ dynText s = do
121121 n <- text' ""
122122 schedulePostBuild $ do
123123 curS <- sample $ current s
124− liftIO $ nodeSetNodeValue n curS
125− addVoidAction $ fmap (liftIO . nodeSetNodeValue n) $ updated s
124+ setNodeValue n $ Just curS
125+ addVoidAction $ fmap (setNodeValue n . Just) $ updated s
126126
127127display :: (MonadWidget t m, Show a) => Dynamic t a -> m ()
128128display a = dynText =<< mapDyn show a
@@ -159,12 +159,12 @@ widgetHoldInternal child0 newChild = do
159159 doc <- askDocument
160160 runWidget <- getRunWidget
161161 let build c = do
162− Just df <- liftIO $ documentCreateDocumentFragment doc
162+ Just df <- createDocumentFragment doc
163163 (result, postBuild, voidActions) <- runWidget df c
164164 runFrameWithTriggerRef newChildBuiltTriggerRef (result, voidActions)
165165 postBuild
166− mp' <- liftIO $ nodeGetParentNode endPlaceholder
167− forM_ mp' $ \p' -> liftIO $ nodeInsertBefore p' (Just df) (Just endPlaceholder)
166+ mp' <- getParentNode endPlaceholder
167+ forM_ mp' $ \p' -> insertBefore p' (Just df) (Just endPlaceholder)
168168 return ()
169169 addVoidAction $ ffor newChild $ \c -> do
170170 liftIO $ deleteBetweenExclusive startPlaceholder endPlaceholder
@@ -209,7 +209,7 @@ listWithKeyShallowDiff initialVals valsChanged mkChild = do
209209 Nothing -> Just Nothing -- Even if we let a Nothing through when the element doesn't already exist, this doesn't cause a problem because it is ignored
210210 Just _ -> Nothing -- We don't want to let spurious re-creations of items through
211211 listHoldWithKey initialVals (attachWith (flip (Map.differenceWith relevantDiff)) (current sentVals) valsChanged) $ \k v ->
212− mkChild k v $ select childValChangedSelector $ Const2 k
212+ mkChild k v $ Reflex.select childValChangedSelector $ Const2 k
213213
214214-- | Display the given map of items using the builder function provided, and update it with the given event. 'Nothing' entries will delete the corresponding children, and 'Just' entries will create or replace them. Since child events do not take any signal arguments, they are always rebuilt. To update a child without rebuilding, either embed signals in the map's values, or refer to them directly in the builder function.
215215listHoldWithKey :: (Ord k, MonadWidget t m) => Map k v -> Event t (Map k (Maybe v)) -> (k -> v -> m a) -> m (Dynamic t (Map k a))
@@ -225,13 +225,13 @@ listHoldWithKey initialVals valsChanged mkChild = do
225225 result <- mkChild k v
226226 childEnd <- text' ""
227227 return (result, (childStart, childEnd))
228− Just dfOrig <- liftIO $ documentCreateDocumentFragment doc
228+ Just dfOrig <- createDocumentFragment doc
229229 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
230230 stateRef <- liftIO $ newIORef initialState
231231 children <- holdDyn initialState newChildren
232232 addVoidAction $ switch $ fmap (mergeWith (>>) . map snd . Map.elems) $ current children
233− mpOrig <- liftIO $ nodeGetParentNode endPlaceholder
234− forM_ mpOrig $ \pOrig -> liftIO $ nodeInsertBefore pOrig (Just dfOrig) (Just endPlaceholder)
233+ mpOrig <- getParentNode endPlaceholder
234+ forM_ mpOrig $ \pOrig -> insertBefore pOrig (Just dfOrig) (Just endPlaceholder)
235235 addVoidAction $ flip fmap valsChanged $ \newVals -> do
236236 curState <- liftIO $ readIORef stateRef
237237 --TODO: Should we remove the parent from the DOM first to avoid reflows?
@@ -241,24 +241,24 @@ listHoldWithKey initialVals valsChanged mkChild = do
241241 return Nothing
242242 These ((_, (start, end)), _) (Just v) -> do -- Replacing existing child
243243 liftIO $ deleteBetweenExclusive start end
244− Just df <- liftIO $ documentCreateDocumentFragment doc
244+ Just df <- createDocumentFragment doc
245245 (childResult, childPostBuild, childVoidAction) <- lift $ buildChild df k v
246246 let s = (childResult, childVoidAction)
247247 modify (>>childPostBuild)
248− mp <- liftIO $ nodeGetParentNode end
249− forM_ mp $ \p -> liftIO $ nodeInsertBefore p (Just df) (Just end)
248+ mp <- getParentNode end
249+ forM_ mp $ \p -> insertBefore p (Just df) (Just end)
250250 return $ Just s
251251 That Nothing -> return Nothing -- Deleting non-existent child
252252 That (Just v) -> do -- Creating new child
253− Just df <- liftIO $ documentCreateDocumentFragment doc
253+ Just df <- createDocumentFragment doc
254254 (childResult, childPostBuild, childVoidAction) <- lift $ buildChild df k v
255255 let s = (childResult, childVoidAction)
256256 modify (>>childPostBuild)
257257 let placeholder = case Map.lookupGT k curState of
258258 Nothing -> endPlaceholder
259259 Just (_, ((_, (start, _)), _)) -> start
260− mp <- liftIO $ nodeGetParentNode placeholder
261− forM_ mp $ \p -> liftIO $ nodeInsertBefore p (Just df) (Just placeholder)
260+ mp <- getParentNode placeholder
261+ forM_ mp $ \p -> insertBefore p (Just df) (Just placeholder)
262262 return $ Just s
263263 This state -> do -- No change
264264 return $ Just state
@@ -304,40 +304,40 @@ selectViewListWithKey_ selection vals mkChild = liftM (fmap fst) $ selectViewLis
304304-- | s and e must both be children of the same node and s must precede e
305305deleteBetweenExclusive :: (IsNode start, IsNode end) => start -> end -> IO ()
306306deleteBetweenExclusive 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
308308 case mCurrentParent of
309309 Nothing -> return () --TODO: Is this the right behavior?
310310 Just currentParent -> do
311311 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
313313 when (toNode s /= toNode x) $ do
314− _ <- nodeRemoveChild currentParent $ Just x
314+ _ <- removeChild currentParent $ Just x
315315 go
316316 go
317317
318318-- | s and e must both be children of the same node and s must precede e
319319deleteBetweenInclusive :: (IsNode start, IsNode end) => start -> end -> IO ()
320320deleteBetweenInclusive 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
322322 case mCurrentParent of
323323 Nothing -> return () --TODO: Is this the right behavior?
324324 Just currentParent -> do
325325 let go = do
326− Just x <- nodeGetPreviousSibling e -- This can't be Nothing because we should hit 's' first
327− _ <- nodeRemoveChild currentParent $ Just x
326+ Just x <- getPreviousSibling e -- This can't be Nothing because we should hit 's' first
327+ _ <- removeChild currentParent $ Just x
328328 when (toNode s /= toNode x) go
329329 go
330− _ <- nodeRemoveChild currentParent $ Just e
330+ _ <- removeChild currentParent $ Just e
331331 return ()
332332
333333--------------------------------------------------------------------------------
334334-- Adapters
335335--------------------------------------------------------------------------------
336336
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)
338338wrapDomEvent element elementOnevent getValue = wrapDomEventMaybe element elementOnevent $ liftM Just getValue
339339
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)
341341wrapDomEventMaybe element elementOnevent getValue = do
342342 postGui <- askPostGui
343343 runWithActions <- askRunWithActions
@@ -378,11 +378,11 @@ data EventTag
378378 | MouseoutTag
379379 | MouseoverTag
380380 | 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
382382 | ScrollTag
383383 | SelectTag
384384 | SubmitTag
385−-- | WheelTag -- See MousewheelTag
385+ | WheelTag
386386 | BeforecutTag
387387 | CutTag
388388 | BeforecopyTag
@@ -426,11 +426,11 @@ data EventName :: EventTag -> * where
426426 Mouseout :: EventName 'MouseoutTag
427427 Mouseover :: EventName 'MouseoverTag
428428 Mouseup :: EventName 'MouseupTag
429− --Mousewheel :: EventName 'MousewheelTag
429+ Mousewheel :: EventName 'MousewheelTag
430430 Scroll :: EventName 'ScrollTag
431431 Select :: EventName 'SelectTag
432432 Submit :: EventName 'SubmitTag
433− --Wheel :: EventName 'WheelTag
433+ Wheel :: EventName 'WheelTag
434434 Beforecut :: EventName 'BeforecutTag
435435 Cut :: EventName 'CutTag
436436 Beforecopy :: EventName 'BeforecopyTag
@@ -447,8 +447,8 @@ data EventName :: EventTag -> * where
447447
448448type family EventType en where
449449 EventType 'AbortTag = UIEvent
450− EventType 'BlurTag = UIEvent
451− EventType 'ChangeTag = UIEvent
450+ EventType 'BlurTag = FocusEvent
451+ EventType 'ChangeTag = DOM.Event
452452 EventType 'ClickTag = MouseEvent
453453 EventType 'ContextmenuTag = MouseEvent
454454 EventType 'DblclickTag = MouseEvent
@@ -460,87 +460,87 @@ type family EventType en where
460460 EventType 'DragstartTag = MouseEvent
461461 EventType 'DropTag = MouseEvent
462462 EventType 'ErrorTag = UIEvent
463− EventType 'FocusTag = UIEvent
464− EventType 'InputTag = UIEvent
465− EventType 'InvalidTag = UIEvent
466− EventType 'KeydownTag = UIEvent
467− EventType 'KeypressTag = UIEvent
468− EventType 'KeyupTag = UIEvent
463+ EventType 'FocusTag = FocusEvent
464+ EventType 'InputTag = DOM.Event
465+ EventType 'InvalidTag = DOM.Event
466+ EventType 'KeydownTag = KeyboardEvent
467+ EventType 'KeypressTag = KeyboardEvent
468+ EventType 'KeyupTag = KeyboardEvent
469469 EventType 'LoadTag = UIEvent
470470 EventType 'MousedownTag = MouseEvent
471− EventType 'MouseenterTag = UIEvent
472− EventType 'MouseleaveTag = UIEvent
471+ EventType 'MouseenterTag = MouseEvent
472+ EventType 'MouseleaveTag = MouseEvent
473473 EventType 'MousemoveTag = MouseEvent
474474 EventType 'MouseoutTag = MouseEvent
475475 EventType 'MouseoverTag = MouseEvent
476476 EventType 'MouseupTag = MouseEvent
477− --EventType 'MousewheelTag = MouseEvent
477+ EventType 'MousewheelTag = MouseEvent
478478 EventType 'ScrollTag = UIEvent
479479 EventType 'SelectTag = UIEvent
480− EventType 'SubmitTag = UIEvent
481− --EventType 'WheelTag = UIEvent
482− EventType 'BeforecutTag = UIEvent
483− EventType 'CutTag = UIEvent
484− EventType 'BeforecopyTag = UIEvent
485− EventType 'CopyTag = UIEvent
486− EventType 'BeforepasteTag = UIEvent
487− EventType 'PasteTag = UIEvent
488− EventType 'ResetTag = UIEvent
489− EventType 'SearchTag = UIEvent
490− EventType 'SelectstartTag = UIEvent
491− EventType 'TouchstartTag = UIEvent
492− EventType 'TouchmoveTag = UIEvent
493− EventType 'TouchendTag = UIEvent
494− EventType 'TouchcancelTag = UIEvent
495−
496−onEventName :: IsElement e => EventName en -> e -> EventM (EventType en) e () -> IO (IO ())
497−onEventName en = case en of
498− Abort -> elementOnabort
499− Blur -> elementOnblur
500− Change -> elementOnchange
501− Click -> elementOnclick
502− Contextmenu -> elementOncontextmenu
503− Dblclick -> elementOndblclick
504− Drag -> elementOndrag
505− Dragend -> elementOndragend
506− Dragenter -> elementOndragenter
507− Dragleave -> elementOndragleave
508− Dragover -> elementOndragover
509− Dragstart -> elementOndragstart
510− Drop -> elementOndrop
511− Error -> elementOnerror
512− Focus -> elementOnfocus
513− Input -> elementOninput
514− Invalid -> elementOninvalid
515− Keydown -> elementOnkeydown
516− Keypress -> elementOnkeypress
517− Keyup -> elementOnkeyup
518− Load -> elementOnload
519− Mousedown -> elementOnmousedown
520− Mouseenter -> elementOnmouseenter
521− Mouseleave -> elementOnmouseleave
522− Mousemove -> elementOnmousemove
523− Mouseout -> elementOnmouseout
524− Mouseover -> elementOnmouseover
525− Mouseup -> elementOnmouseup
526− --Mousewheel -> elementOnmousewheel
527− Scroll -> elementOnscroll
528− Select -> elementOnselect
529− Submit -> elementOnsubmit
530− --Wheel -> elementOnwheel
531− Beforecut -> elementOnbeforecut
532− Cut -> elementOncut
533− Beforecopy -> elementOnbeforecopy
534− Copy -> elementOncopy
535− Beforepaste -> elementOnbeforepaste
536− Paste -> elementOnpaste
537− Reset -> elementOnreset
538− Search -> elementOnsearch
539− Selectstart -> elementOnselectstart
540− Touchstart -> elementOntouchstart
541− Touchmove -> elementOntouchmove
542− Touchend -> elementOntouchend
543− Touchcancel -> elementOntouchcancel
480+ EventType 'SubmitTag = DOM.Event
481+ EventType 'WheelTag = WheelEvent
482+ EventType 'BeforecutTag = DOM.Event
483+ EventType 'CutTag = DOM.Event
484+ EventType 'BeforecopyTag = DOM.Event
485+ EventType 'CopyTag = DOM.Event
486+ EventType 'BeforepasteTag = DOM.Event
487+ EventType 'PasteTag = DOM.Event
488+ EventType 'ResetTag = DOM.Event
489+ EventType 'SearchTag = DOM.Event
490+ EventType 'SelectstartTag = DOM.Event
491+ EventType 'TouchstartTag = TouchEvent
492+ EventType 'TouchmoveTag = TouchEvent
493+ EventType 'TouchendTag = TouchEvent
494+ EventType 'TouchcancelTag = TouchEvent
495+
496+onEventName :: IsElement e => EventName en -> e -> EventM e (EventType en) () -> IO (IO ())
497+onEventName en e = case en of
498+ Abort -> on e E.abort
499+ Blur -> on e E.blurEvent
500+ Change -> on e E.change
501+ Click -> on e E.click
502+ Contextmenu -> on e E.contextMenu
503+ Dblclick -> on e E.dblClick
504+ Drag -> on e E.drag
505+ Dragend -> on e E.dragEnd
506+ Dragenter -> on e E.dragEnter
507+ Dragleave -> on e E.dragLeave
508+ Dragover -> on e E.dragOver
509+ Dragstart -> on e E.dragStart
510+ Drop -> on e E.drop
511+ Error -> on e E.error
512+ Focus -> on e E.focusEvent
513+ Input -> on e E.input
514+ Invalid -> on e E.invalid
515+ Keydown -> on e E.keyDown
516+ Keypress -> on e E.keyPress
517+ Keyup -> on e E.keyUp
518+ Load -> on e E.load
519+ Mousedown -> on e E.mouseDown
520+ Mouseenter -> on e E.mouseEnter
521+ Mouseleave -> on e E.mouseLeave
522+ Mousemove -> on e E.mouseMove
523+ Mouseout -> on e E.mouseOut
524+ Mouseover -> on e E.mouseOver
525+ Mouseup -> on e E.mouseUp
526+ Mousewheel -> on e E.mouseWheel
527+ Scroll -> on e E.scroll
528+ Select -> on e E.select
529+ Submit -> on e E.submit
530+ Wheel -> on e E.wheel
531+ Beforecut -> on e E.beforeCut
532+ Cut -> on e E.cut
533+ Beforecopy -> on e E.beforeCopy
534+ Copy -> on e E.copy
535+ Beforepaste -> on e E.beforePaste
536+ Paste -> on e E.paste
537+ Reset -> on e E.reset
538+ Search -> on e E.search
539+ Selectstart -> on e E.selectStart
540+ Touchstart -> on e E.touchStart
541+ Touchmove -> on e E.touchMove
542+ Touchend -> on e E.touchEnd
543+ Touchcancel -> on e E.touchCancel
544544
545545newtype EventResult en = EventResult { unEventResult :: EventResultType en }
546546
@@ -590,41 +590,40 @@ type family EventResultType (en :: EventTag) :: * where
590590 EventResultType 'TouchendTag = ()
591591 EventResultType 'TouchcancelTag = ()
592592
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))
594594wrapDomEventsMaybe element handlers = do
595595 postGui <- askPostGui
596596 runWithActions <- askRunWithActions
597597 e <- newFanEventWithTrigger $ \(WrapArg en) et -> do
598− unsubscribe <- liftIO $ (onEventName en) element $ do
598+ unsubscribe <- onEventName en element $ do
599599 mv <- handlers en
600600 forM_ mv $ \v -> liftIO $ postGui $ runWithActions [et :=> v]
601601 return $ liftIO $ do
602602 unsubscribe
603603 return $! e
604604
605−getKeyEvent :: EventM UIEvent e Int
605+getKeyEvent :: EventM e KeyboardEvent Int
606606getKeyEvent = do
607607 e <- event
608− liftIO $ do
609− which <- uiEventGetWhich e
610− if which /= 0 then return which else do
611− charCode <- uiEventGetCharCode e
612− if charCode /= 0 then return charCode else
613− uiEventGetKeyCode e
614−
615−getMouseEventCoords :: EventM MouseEvent e (Int, Int)
608+ which <- getWhich e
609+ if which /= 0 then return which else do
610+ charCode <- getCharCode e
611+ if charCode /= 0 then return charCode else
612+ getKeyCode e
613+
614+getMouseEventCoords :: EventM e MouseEvent (Int, Int)
616615getMouseEventCoords = do
617616 e <- event
618− liftIO $ bisequence (mouseEventGetClientX e, mouseEventGetClientY e)
617+ bisequence (getX e, getY e)
619618
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))
621620defaultDomEventHandler e evt = liftM (Just . EventResult) $ case evt of
622621 Click -> return ()
623622 Dblclick -> return ()
624623 Keypress -> getKeyEvent
624+ Scroll -> getScrollTop e
625625 Keydown -> getKeyEvent
626626 Keyup -> getKeyEvent
627− Scroll -> liftIO $ elementGetScrollTop e
628627 Mousemove -> getMouseEventCoords
629628 Mouseup -> getMouseEventCoords
630629 Mousedown -> getMouseEventCoords
@@ -664,7 +663,7 @@ defaultDomEventHandler e evt = liftM (Just . EventResult) $ case evt of
664663 Touchend -> return ()
665664 Touchcancel -> return ()
666665
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)
668667wrapElement eh e = do
669668 es <- wrapDomEventsMaybe e $ eh e
670669 return $ El e es
@@ -749,17 +748,15 @@ simpleList xs mkChild = mapDyn (map snd . Map.toList) =<< flip list mkChild =<<
749748elDynHtml' :: MonadWidget t m => String -> Dynamic t String -> m (El t)
750749elDynHtml' elementTag html = do
751750 e <- buildEmptyElement elementTag (Map.empty :: Map String String)
752− let h = castToHTMLElement e
753− schedulePostBuild $ liftIO . htmlElementSetInnerHTML h =<< sample (current html)
754− addVoidAction $ fmap (liftIO . htmlElementSetInnerHTML h) $ updated html
751+ schedulePostBuild $ setInnerHTML e . Just =<< sample (current html)
752+ addVoidAction $ fmap (setInnerHTML e . Just) $ updated html
755753 wrapElement defaultDomEventHandler e
756754
757755elDynHtmlAttr' :: MonadWidget t m => String -> Map String String -> Dynamic t String -> m (El t)
758756elDynHtmlAttr' elementTag attrs html = do
759757 e <- buildEmptyElement elementTag attrs
760− let h = castToHTMLElement e
761− schedulePostBuild $ liftIO . htmlElementSetInnerHTML h =<< sample (current html)
762− addVoidAction $ fmap (liftIO . htmlElementSetInnerHTML h) $ updated html
758+ schedulePostBuild $ setInnerHTML e . Just =<< sample (current html)
759+ addVoidAction $ fmap (setInnerHTML e . Just) $ updated html
763760 wrapElement defaultDomEventHandler e
764761
765762data Link t
@@ -784,7 +781,7 @@ class HasDomEvent t a where
784781 domEvent :: EventName en -> a -> Event t (EventResultType en)
785782
786783instance 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)
788785
789786linkClass :: MonadWidget t m => String -> String -> m (Link t)
790787linkClass s c = do
@@ -859,7 +856,7 @@ tabDisplay ulClass activeClass tabItems = do
859856 _ <- listWithKey dTabs (\k dTab -> do
860857 dAttrs <- mapDyn (\sel -> do
861858 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
863860 elDynAttr "div" dAttrs $ dyn =<< mapDyn snd dTab)
864861 return ()
865862 where
@@ -874,7 +871,7 @@ tabDisplay ulClass activeClass tabItems = do
874871unsafePlaceElement :: MonadWidget t m => Element -> m (El t)
875872unsafePlaceElement e = do
876873 p <- askParent
877− _ <- liftIO $ nodeAppendChild p $ Just e
874+ _ <- appendChild p $ Just e
878875 wrapElement defaultDomEventHandler e
879876
880877deriveGEq ''EventName
src/Reflex/Dom/Widget/Input.hs+32−33
@@ -8,13 +8,13 @@ import Reflex.Dom.Widget.Basic
88
99import Reflex
1010import Reflex.Host.Class
11−import GHCJS.DOM.HTMLInputElement
12−import GHCJS.DOM.HTMLTextAreaElement
13−import GHCJS.DOM.Element
14−import GHCJS.DOM.HTMLSelectElement
11+import GHCJS.DOM.HTMLInputElement as Input
12+import GHCJS.DOM.HTMLTextAreaElement as TextArea
13+import GHCJS.DOM.Element hiding (error)
14+import GHCJS.DOM.HTMLSelectElement as Select
1515import GHCJS.DOM.EventM
1616import GHCJS.DOM.File
17−import GHCJS.DOM.FileList
17+import qualified GHCJS.DOM.FileList as FileList
1818import Data.Monoid
1919import Data.Map as Map
2020import Control.Lens
@@ -53,21 +53,21 @@ instance Reflex t => Default (TextInputConfig t) where
5353textInput :: MonadWidget t m => TextInputConfig t -> m (TextInput t)
5454textInput (TextInputConfig inputType initial eSetValue dAttrs) = do
5555 e <- liftM castToHTMLInputElement $ buildEmptyElement "input" =<< mapDyn (Map.insert "type" inputType) dAttrs
56− liftIO $ htmlInputElementSetValue e initial
57− performEvent_ $ fmap (liftIO . htmlInputElementSetValue e) eSetValue
58− eChange <- wrapDomEvent e elementOninput $ liftIO $ htmlInputElementGetValue e
56+ Input.setValue e $ Just initial
57+ performEvent_ $ fmap (Input.setValue e . Just) eSetValue
58+ eChange <- wrapDomEvent e (`on` input) $ fromMaybe "" <$> Input.getValue e
5959 postGui <- askPostGui
6060 runWithActions <- askRunWithActions
6161 eChangeFocus <- newEventWithTrigger $ \eChangeFocusTrigger -> do
62− unsubscribeOnblur <- liftIO $ elementOnblur e $ liftIO $ do
62+ unsubscribeOnblur <- on e blurEvent $ liftIO $ do
6363 postGui $ runWithActions [eChangeFocusTrigger :=> False]
64− unsubscribeOnfocus <- liftIO $ elementOnfocus e $ liftIO $ do
64+ unsubscribeOnfocus <- on e focusEvent $ liftIO $ do
6565 postGui $ runWithActions [eChangeFocusTrigger :=> True]
6666 return $ liftIO $ unsubscribeOnblur >> unsubscribeOnfocus
6767 dFocus <- holdDyn False eChangeFocus
68− eKeypress <- wrapDomEvent e elementOnkeypress getKeyEvent
69− eKeydown <- wrapDomEvent e elementOnkeydown getKeyEvent
70− eKeyup <- wrapDomEvent e elementOnkeyup getKeyEvent
68+ eKeypress <- wrapDomEvent e (`on` keyPress) getKeyEvent
69+ eKeydown <- wrapDomEvent e (`on` keyDown) getKeyEvent
70+ eKeyup <- wrapDomEvent e (`on` keyUp) getKeyEvent
7171 dValue <- holdDyn initial $ leftmost [eSetValue, eChange]
7272 return $ TextInput dValue eChange eKeypress eKeydown eKeyup dFocus e
7373
@@ -97,20 +97,20 @@ data TextArea t
9797textArea :: MonadWidget t m => TextAreaConfig t -> m (TextArea t)
9898textArea (TextAreaConfig initial eSet attrs) = do
9999 e <- liftM castToHTMLTextAreaElement $ buildEmptyElement "textarea" attrs
100− liftIO $ htmlTextAreaElementSetValue e initial
100+ TextArea.setValue e $ Just initial
101101 postGui <- askPostGui
102102 runWithActions <- askRunWithActions
103103 eChangeFocus <- newEventWithTrigger $ \eChangeFocusTrigger -> do
104− unsubscribeOnblur <- liftIO $ elementOnblur e $ liftIO $ do
104+ unsubscribeOnblur <- on e blurEvent $ liftIO $ do
105105 postGui $ runWithActions [eChangeFocusTrigger :=> False]
106− unsubscribeOnfocus <- liftIO $ elementOnfocus e $ liftIO $ do
106+ unsubscribeOnfocus <- on e focusEvent $ liftIO $ do
107107 postGui $ runWithActions [eChangeFocusTrigger :=> True]
108108 return $ liftIO $ unsubscribeOnblur >> unsubscribeOnfocus
109− performEvent_ $ fmap (liftIO . htmlTextAreaElementSetValue e) eSet
109+ performEvent_ $ fmap (TextArea.setValue e . Just) eSet
110110 f <- holdDyn False eChangeFocus
111− ev <- wrapDomEvent e elementOninput $ liftIO $ htmlTextAreaElementGetValue e
111+ ev <- wrapDomEvent e (`on` input) $ fromMaybe "" <$> TextArea.getValue e
112112 v <- holdDyn initial $ leftmost [eSet, ev]
113− eKeypress <- wrapDomEvent e elementOnkeypress getKeyEvent
113+ eKeypress <- wrapDomEvent e (`on` keyPress) getKeyEvent
114114 return $ TextArea v ev e f eKeypress
115115
116116data CheckboxConfig t
@@ -135,21 +135,21 @@ checkbox :: MonadWidget t m => Bool -> CheckboxConfig t -> m (Checkbox t)
135135checkbox checked config = do
136136 attrs <- mapDyn (\c -> Map.insert "type" "checkbox" $ (if checked then Map.insert "checked" "checked" else Map.delete "checked") c) (_checkboxConfig_attributes config)
137137 e <- liftM castToHTMLInputElement $ buildEmptyElement "input" attrs
138− eClick <- wrapDomEvent e elementOnclick $ liftIO $ htmlInputElementGetChecked e
139− performEvent_ $ fmap (\v -> liftIO $ htmlInputElementSetChecked e $! v) $ _checkboxConfig_setValue config
138+ eClick <- wrapDomEvent e (`on` click) $ Input.getChecked e
139+ performEvent_ $ fmap (\v -> Input.setChecked e $! v) $ _checkboxConfig_setValue config
140140 dValue <- holdDyn checked $ leftmost [_checkboxConfig_setValue config, eClick]
141141 return $ Checkbox dValue eClick
142142
143143checkboxView :: MonadWidget t m => Dynamic t (Map String String) -> Dynamic t Bool -> m (Event t Bool)
144144checkboxView dAttrs dValue = do
145145 e <- liftM castToHTMLInputElement $ buildEmptyElement "input" =<< mapDyn (Map.insert "type" "checkbox") dAttrs
146− eClicked <- wrapDomEvent e elementOnclick $ do
146+ eClicked <- wrapDomEvent e (`on` click) $ do
147147 preventDefault
148− liftIO $ htmlInputElementGetChecked e
148+ Input.getChecked e
149149 schedulePostBuild $ do
150150 v <- sample $ current dValue
151− when v $ liftIO $ htmlInputElementSetChecked e True
152− performEvent_ $ fmap (\v -> liftIO $ htmlInputElementSetChecked e $! v) $ updated dValue
151+ when v $ Input.setChecked e True
152+ performEvent_ $ fmap (\v -> Input.setChecked e $! v) $ updated dValue
153153 return eClicked
154154
155155data FileInput t
@@ -168,10 +168,10 @@ instance Reflex t => Default (FileInputConfig t) where
168168fileInput :: MonadWidget t m => FileInputConfig t -> m (FileInput t)
169169fileInput (FileInputConfig dAttrs) = do
170170 e <- liftM castToHTMLInputElement $ buildEmptyElement "input" =<< mapDyn (Map.insert "type" "file") dAttrs
171− eChange <- wrapDomEvent e elementOnchange $ liftIO $ do
172− Just files <- htmlInputElementGetFiles e
173− len <- fileListGetLength files
174− mapM (liftM (fromMaybe (error "fileInput: fileListItem returned null")) . fileListItem files) $ init [0..len]
171+ eChange <- wrapDomEvent e (flip on change) $ do
172+ Just files <- getFiles e
173+ len <- FileList.getLength files
174+ mapM (liftM (fromMaybe (error "fileInput: fileListItem returned null")) . FileList.item files) $ init [0..len]
175175 dValue <- holdDyn [] eChange
176176 return $ FileInput dValue e
177177
@@ -201,9 +201,9 @@ dropdown k0 options (DropdownConfig setK attrs) = do
201201 listWithKey optionsWithDefault $ \k v -> do
202202 elAttr "option" ("value" =: show k <> if k == k0 then "selected" =: "selected" else mempty) $ dynText v
203203 let e = castToHTMLSelectElement $ _el_element eRaw
204− performEvent_ $ fmap (liftIO . htmlSelectElementSetValue e . show) setK
205− eChange <- wrapDomEvent e elementOnchange $ do
206− kStr <- liftIO $ htmlSelectElementGetValue e
204+ performEvent_ $ fmap (Select.setValue e . Just . show) setK
205+ eChange <- wrapDomEvent e (`on` change) $ do
206+ kStr <- fromMaybe "" <$> Select.getValue e
207207 return $ readMay kStr
208208 let readKey opts mk = fromMaybe k0 $ do
209209 k <- mk
@@ -320,4 +320,3 @@ instance HasStateModeWitness Edit where
320320instance HasStateModeWitness View where
321321 stateModeWitness = ViewWitness
322322-}
323−
src/Reflex/Dom/Widget/Lazy.hs+2−2
@@ -49,7 +49,7 @@ virtualListWithSelection heightPx rowPx maxIndex i0 setI listTag listAttrs rowTa
4949 window <- combineDyn (\h -> findWindow h rowPx) heightPx scrollPosition
5050 itemsInWindow <- combineDyn (\(_,(idx,num)) is -> Map.fromList $ map (\i -> let ix = indexToKey i in (ix, Map.lookup ix is)) [idx .. idx + num]) window items
5151 postBuild <- getPostBuild
52− performEvent_ $ fmap (\i -> liftIO $ elementSetScrollTop (_el_element container) (i * rowPx)) $ leftmost [setI, fmap (const i0) postBuild]
52+ performEvent_ $ fmap (\i -> liftIO $ setScrollTop (_el_element container) (i * rowPx)) $ leftmost [setI, fmap (const i0) postBuild]
5353 indexAndLength <- mapDyn snd window
5454 return (indexAndLength, sel)
5555 where
@@ -92,7 +92,7 @@ virtualList heightPx rowPx maxIndex i0 setI keyToIndex items0 itemsUpdate itemBu
9292 , fmap (const (i0 * rowPx)) pb
9393 ]
9494 window <- combineDyn (\h -> findWindow h rowPx) heightPx scrollPosition
95− performEvent_ $ fmap (\i -> liftIO $ elementSetScrollTop (_el_element viewport) (i * rowPx)) $ leftmost [setI, fmap (const i0) pb]
95+ performEvent_ $ fmap (\i -> liftIO $ setScrollTop (_el_element viewport) (i * rowPx)) $ leftmost [setI, fmap (const i0) pb]
9696 return (nubDyn window, result)
9797 where
9898 toStyleAttr m = "style" =: (Map.foldWithKey (\k v s -> k <> ":" <> v <> ";" <> s) "" m)
src/Reflex/Dom/Widget/Resize.hs+18−17
@@ -9,6 +9,7 @@ import Control.Monad
99import Control.Monad.IO.Class
1010import Data.Monoid
1111import GHCJS.DOM.Element
12+import GHCJS.DOM.EventM (on)
1213
1314-- | A widget that wraps the given widget in a div and fires an event when resized.
1415-- Adapted from github.com/marcj/css-element-queries
@@ -31,31 +32,31 @@ resizeDetectorWithStyle styleString w = do
3132 let reset = do
3233 let e = _el_element expand
3334 s = _el_element shrink
34− eow <- elementGetOffsetWidth e
35− eoh <- elementGetOffsetHeight e
35+ eow <- getOffsetWidth e
36+ eoh <- getOffsetHeight e
3637 let ecw = eow + 10
3738 ech = eoh + 10
38− elementSetAttribute (_el_element expandChild) "style" (childStyle <> "width: " <> show ecw <> "px;" <> "height: " <> show ech <> "px;")
39− esw <- elementGetScrollWidth e
40− elementSetScrollLeft e esw
41− esh <- elementGetScrollHeight e
42− elementSetScrollTop e esh
43− ssw <- elementGetScrollWidth s
44− elementSetScrollLeft s ssw
45− ssh <- elementGetScrollHeight s
46− elementSetScrollTop s ssh
47− lastWidth <- elementGetOffsetWidth (_el_element parent)
48− lastHeight <- elementGetOffsetHeight (_el_element parent)
39+ setAttribute (_el_element expandChild) "style" (childStyle <> "width: " <> show ecw <> "px;" <> "height: " <> show ech <> "px;")
40+ esw <- getScrollWidth e
41+ setScrollLeft e esw
42+ esh <- getScrollHeight e
43+ setScrollTop e esh
44+ ssw <- getScrollWidth s
45+ setScrollLeft s ssw
46+ ssh <- getScrollHeight s
47+ setScrollTop s ssh
48+ lastWidth <- getOffsetWidth (_el_element parent)
49+ lastHeight <- getOffsetHeight (_el_element parent)
4950 return (Just lastWidth, Just lastHeight)
5051 resetIfChanged ds = do
51− pow <- elementGetOffsetWidth (_el_element parent)
52− poh <- elementGetOffsetHeight (_el_element parent)
52+ pow <- getOffsetWidth (_el_element parent)
53+ poh <- getOffsetHeight (_el_element parent)
5354 if ds == (Just pow, Just poh)
5455 then return Nothing
5556 else liftM Just reset
5657 pb <- getPostBuild
57− expandScroll <- wrapDomEvent (_el_element expand) elementOnscroll $ return ()
58− shrinkScroll <- wrapDomEvent (_el_element shrink) elementOnscroll $ return ()
58+ expandScroll <- wrapDomEvent (_el_element expand) (`on` scroll) $ return ()
59+ shrinkScroll <- wrapDomEvent (_el_element shrink) (`on` scroll) $ return ()
5960 size0 <- performEvent $ fmap (const $ liftIO reset) pb
6061 rec resize <- performEventAsync $ fmap (\d cb -> liftIO $ cb =<< resetIfChanged d) $ tag (current dimensions) $ leftmost [expandScroll, shrinkScroll]
6162 dimensions <- holdDyn (Nothing, Nothing) $ leftmost [ size0, fmapMaybe id resize ]
src/Reflex/Dom/Xhr.hs+1−1
@@ -49,7 +49,7 @@ data XhrRequestConfig
4949 = XhrRequestConfig { _xhrRequestConfig_headers :: Map String String
5050 , _xhrRequestConfig_user :: Maybe String
5151 , _xhrRequestConfig_password :: Maybe String
52− , _xhrRequestConfig_responseType :: Maybe String
52+ , _xhrRequestConfig_responseType :: Maybe XMLHttpRequestResponseType
5353 , _xhrRequestConfig_sendData :: Maybe String
5454 }
5555 deriving (Show, Read, Eq, Ord, Typeable)