git.iko.soy/reflex-dom
on develop help sign in
Merge develop into dynamic-writer

Conflicts: src/Reflex/Dom.hs src/Reflex/Dom/Widget/Basic.hs

commit172a48cfa145808febc2cb9d221edd068bca8ed9 authorCale Gibbard <cgibbard@gmail.com> dateWed 2 Mar 2016, 11:53 (11 years ago) parentb48af176094079
24 files changed+1063−724
compare with develop
unifiedsplit
README.md+9−5 default.nix+5−5 reflex-dom.cabal+27−16 src-ghc/Reflex/Dom/Internal/Foreign.hs+103−9 src-ghc/Reflex/Dom/WebSocket/Foreign.hs+70 src-ghc/Reflex/Dom/Xhr/Foreign.hs+101−50 src-ghcjs/Reflex/Dom/Internal/Foreign.hs+38−4 src-ghcjs/Reflex/Dom/WebSocket/Foreign.hs+44 src-ghcjs/Reflex/Dom/Xhr/Foreign.hs+117−365 src/Reflex/Dom.hs+4 src/Reflex/Dom/Class.hs+3−3 src/Reflex/Dom/Internal.hs+16−12 src/Reflex/Dom/Location.hs+3 src/Reflex/Dom/Time.hs+1−1 src/Reflex/Dom/WebSocket.hs+68 src/Reflex/Dom/Widget/Basic.hs+168−157 src/Reflex/Dom/Widget/Input.hs+56−52 src/Reflex/Dom/Widget/Lazy.hs+2−2 src/Reflex/Dom/Widget/Resize.hs+19−18 src/Reflex/Dom/Xhr.hs+107−25 src/Reflex/Dom/Xhr/Exception.hs+12 src/Reflex/Dom/Xhr/ResponseType.hs+21 test/BrokenHaltSpec.hs+40 test/HaltSpec.hs+29
README.md+9−5
@@ -1,13 +1,17 @@
11## Reflex-DOM
22### A Framework for Functional Reactive Web Apps in Haskell
33
4−Reflex-DOM is a framework for building web applications in Haskell, based on the [Functional Reactive Programming](https://wiki.haskell.org/Functional_Reactive_Programming) library [Reflex](https://github.com/ryantrinkle/reflex).
4+Reflex-DOM is a framework for building web applications in Haskell, based on the [Functional Reactive Programming](https://wiki.haskell.org/Functional_Reactive_Programming) library [Reflex](https://github.com/reflex-frp/reflex).
55
6−Comprehensive documentation is still a work in progress, but a [demo](https://github.com/ryantrinkle/try-reflex) is available and an introductory talk is available at [Part 1](https://www.youtube.com/watch?v=mYvkcskJbc4) / [Part 2](https://www.youtube.com/watch?v=3qfc9XFVo2c) ([Slides](https://obsidian.systems/reflex-nyhug/)).
6+Comprehensive documentation is still a work in progress, but a [demo](https://github.com/reflex-frp/reflex-platform) is available and an introductory talk is available at [Part 1](https://www.youtube.com/watch?v=mYvkcskJbc4) / [Part 2](https://www.youtube.com/watch?v=3qfc9XFVo2c) ([Slides](https://obsidian.systems/reflex-nyhug/)).
7+
8+A summary of Reflex-DOM functions is available in the [quick reference](Quickref.md).
79
810### Additional resources
9−[try reflex](https://github.com/ryantrinkle/try-reflex)
11+[Get started with Reflex](https://github.com/reflex-frp/reflex-platform)
12+
13+[/r/reflexfrp](https://www.reddit.com/r/reflexfrp)
1014
11−[reddit/r/reflexfrp](http://www.reddit.com/r/reflexfrp)
15+[hackage](https://hackage.haskell.org/package/reflex)
1216
13−irc.freenode.net #reflex-frp
17+[irc.freenode.net #reflex-frp](http://webchat.freenode.net?channels=%23reflex-frp&uio=d4)
default.nix+5−5
@@ -1,13 +1,13 @@
11{ mkDerivation, pkgs, dependent-map, ghcjs-dom, lens
2−, mtl, ref-tf, reflex, safe, text, these
2+, mtl, ref-tf, reflex, text, these
33, transformers, data-default, semigroups, aeson
44, ghc, webkitgtk3-javascriptcore, exception-transformers
5−, dependent-sum-template, bifunctors
5+, dependent-sum-template, bifunctors, bimap, raw-strings-qq
66}:
77
88mkDerivation {
99 pname = "reflex-dom";
10− version = "0.2";
10+ version = "0.3";
1111 src = builtins.filterSource (path: type: baseNameOf path != ".git") ./.;
1212 buildDepends = [
1313 reflex
@@ -17,7 +17,6 @@ mkDerivation {
1717 these
1818 lens
1919 ghcjs-dom
20− safe
2120 text
2221 data-default
2322 semigroups
@@ -26,6 +25,7 @@ mkDerivation {
2625 exception-transformers
2726 dependent-sum-template
2827 bifunctors
29− ] ++ (if (ghc.pname or null) == "ghcjs" then [ ] else [ webkitgtk3-javascriptcore ]);
28+ bimap
29+ ] ++ (if (ghc.pname or null) == "ghcjs" then [ ] else [ webkitgtk3-javascriptcore raw-strings-qq ]);
3030 license = null;
3131}
reflex-dom.cabal+27−16
@@ -1,5 +1,5 @@
11Name: reflex-dom
2−Version: 0.2
2+Version: 0.3
33Synopsis: Functional Reactive Web Apps with Reflex
44Description: Reflex-DOM is a Functional Reactive web framework based on the Reflex FRP engine
55License: BSD3
@@ -13,67 +13,78 @@ Cabal-version: >=1.9.2
1313-- Deal with https://github.com/haskell/cabal/issues/2544 / https://github.com/haskell/cabal/issues/367
1414extra-source-files: src-ghc/Reflex/Dom/Internal/Foreign.hs
1515 src-ghc/Reflex/Dom/Xhr/Foreign.hs
16+ src-ghc/Reflex/Dom/WebSocket/Foreign.hs
1617 src-ghcjs/Reflex/Dom/Internal/Foreign.hs
1718 src-ghcjs/Reflex/Dom/Xhr/Foreign.hs
19+ src-ghcjs/Reflex/Dom/WebSocket/Foreign.hs
20+ src/Reflex/Dom/Xhr/ResponseType.hs
21+ src/Reflex/Dom/Xhr/Exception.hs
1822
1923library
2024 hs-source-dirs: src
2125 build-depends:
2226 base >= 4.7 && < 4.9,
23− reflex == 0.3.*,
24− dependent-sum == 0.2.*,
25− dependent-map == 0.1.*,
26− semigroups == 0.16.*,
27+ reflex == 0.4.*,
28+ dependent-sum == 0.3.*,
29+ dependent-map == 0.2.*,
30+ semigroups >= 0.16 && < 0.19,
2731 mtl >= 2.1 && < 2.3,
2832 containers == 0.5.*,
2933 these >= 0.4 && < 0.7,
3034 ref-tf == 0.4.*,
35+ ghcjs-dom >= 0.2.1 && < 0.3,
3136 transformers == 0.3.* || == 0.4.*,
3237 lens >= 4.7 && < 4.14,
33− ghcjs-dom >= 0.1.1.3 && < 0.2,
34− safe == 0.3.*,
3538 text == 1.2.*,
3639 bytestring == 0.10.*,
3740 data-default == 0.5.*,
38− aeson >= 0.8 && < 0.10,
41+ aeson >= 0.8 && < 0.11,
3942 time == 1.4.* || == 1.5.*,
4043 exception-transformers == 0.4.*,
4144 directory == 1.2.*,
4245 dependent-sum-template >= 0.0.0.4 && < 0.1,
43− bifunctors >= 4.2 && < 5.1
46+ bifunctors >= 4.2 && < 6,
47+ bimap >= 0.3 && < 0.4
4448
4549 if impl(ghcjs)
4650 hs-source-dirs: src-ghcjs
47− cpp-options: -D__GHCJS__
4851 build-depends:
4952 ghcjs-base
5053 else
5154 hs-source-dirs: src-ghc
5255 build-depends:
5356 glib == 0.13.*,
54− gtk3 == 0.13.*,
55− webkitgtk3 == 0.13.*,
56− webkitgtk3-javascriptcore == 0.13.*
57+ gtk3 >= 0.13.0 && < 0.15,
58+ webkitgtk3 == 0.14.*,
59+ webkitgtk3-javascriptcore == 0.13.*,
60+ raw-strings-qq
61+ if !os(windows)
62+ build-depends: unix == 2.7.*
5763
5864 exposed-modules:
5965 Reflex.Dom
6066 Reflex.Dom.Class
6167 Reflex.Dom.DynamicWriter
6268 Reflex.Dom.Internal
69+ Reflex.Dom.Time
70+ Reflex.Dom.WebSocket
6371 Reflex.Dom.Widget
6472 Reflex.Dom.Widget.Basic
6573 Reflex.Dom.Widget.Input
6674 Reflex.Dom.Widget.Lazy
6775 Reflex.Dom.Widget.Resize
6876 Reflex.Dom.Xhr
69− Reflex.Dom.Time
77+ Reflex.Dom.Location
7078 other-modules:
7179 Reflex.Dom.Internal.Foreign
80+ Reflex.Dom.WebSocket.Foreign
7281 Reflex.Dom.Xhr.Foreign
82+ Reflex.Dom.Xhr.ResponseType
83+ Reflex.Dom.Xhr.Exception
7384
7485 other-extensions: TemplateHaskell
75− ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2
86+ ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 -ferror-spans
7687
7788source-repository head
7889 type: git
79− location: https://github.com/ryantrinkle/reflex
90+ location: https://github.com/reflex-frp/reflex-dom
src-ghc/Reflex/Dom/Internal/Foreign.hs+103−9
@@ -1,19 +1,47 @@
1−{-# LANGUAGE ForeignFunctionInterface #-}
1+{-# LANGUAGE CPP, ForeignFunctionInterface, ScopedTypeVariables, LambdaCase #-}
22module Reflex.Dom.Internal.Foreign where
33
4−import GHCJS.DOM hiding (runWebGUI)
54import Control.Concurrent
5+import Control.Exception (bracket)
6+import Control.Lens hiding (set)
7+import Control.Monad
68import Control.Monad.State.Strict hiding (mapM, mapM_, forM, forM_, sequence, sequence_, get)
9+import Data.ByteString (ByteString)
10+import Data.List
11+import Foreign.Marshal hiding (void)
12+import Foreign.Ptr
13+import GHCJS.DOM hiding (runWebGUI)
714import GHCJS.DOM.Navigator
8−import GHCJS.DOM.DOMWindow
15+import GHCJS.DOM.Window
916import Graphics.UI.Gtk hiding (Widget)
10−import Graphics.UI.Gtk.WebKit.WebView
11−import Graphics.UI.Gtk.WebKit.Types hiding (Event, Widget, unWidget)
12−import Graphics.UI.Gtk.WebKit.WebSettings
17+import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSBase
18+import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSObjectRef
19+import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSStringRef
20+import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSValueRef
21+import Graphics.UI.Gtk.WebKit.JavaScriptCore.WebFrame
22+import Graphics.UI.Gtk.WebKit.Types hiding (Event, Widget)
1323import Graphics.UI.Gtk.WebKit.WebFrame
1424import Graphics.UI.Gtk.WebKit.WebInspector
15−import Data.List
25+import Graphics.UI.Gtk.WebKit.WebSettings
26+import Graphics.UI.Gtk.WebKit.WebView
1627import System.Directory
28+import System.Glib.FFI hiding (void)
29+import qualified Data.ByteString as BS
30+
31+#ifndef mingw32_HOST_OS
32+import System.Posix.Signals
33+#endif
34+
35+quitWebView :: WebView -> IO ()
36+quitWebView wv = postGUIAsync $ do w <- widgetGetToplevel wv
37+ widgetDestroy w
38+
39+installQuitHandler :: WebView -> IO ()
40+#ifdef mingw32_HOST_OS
41+installQuitHandler wv = return () -- TODO: Maybe figure something out here for Windows users.
42+#else
43+installQuitHandler wv = installHandler keyboardSignal (Catch (quitWebView wv)) Nothing >> return ()
44+#endif
1745
1846makeDefaultWebView :: String -> (WebView -> IO ()) -> IO ()
1947makeDefaultWebView userAgentKey main = do
@@ -50,6 +78,7 @@ makeDefaultWebView userAgentKey main = do
5078 wf <- webViewGetMainFrame webView
5179 pwd <- getCurrentDirectory
5280 webFrameLoadString wf "" Nothing $ "file://" ++ pwd ++ "/"
81+ installQuitHandler webView
5382 mainGUI
5483
5584runWebGUI :: (WebView -> IO ()) -> IO ()
@@ -62,8 +91,73 @@ runWebGUI' userAgentKey main = do
6291 case mbWindow of
6392 Just window -> do
6493 -- Check if we are running in javascript inside the the native version
65− Just n <- domWindowGetNavigator window
66− agent <- navigatorGetUserAgent n
94+ Just n <- getNavigator window
95+ agent <- getUserAgent n
6796 unless ((" " ++ userAgentKey) `isSuffixOf` agent) $ main (castToWebView window)
6897 Nothing -> do
6998 makeDefaultWebView userAgentKey main
99+
100+foreign import ccall "wrapper"
101+ wrapper :: JSObjectCallAsFunctionCallback' -> IO JSObjectCallAsFunctionCallback
102+
103+toJSObject :: JSContextRef -> [Ptr OpaqueJSValue] -> IO JSObjectRef
104+toJSObject ctx args = do
105+ o <- jsobjectmake ctx nullPtr nullPtr
106+ iforM_ args $ \n a -> do
107+ prop <- jsstringcreatewithutf8cstring $ show n
108+ jsobjectsetproperty ctx o prop a 1 nullPtr
109+ return o
110+
111+fromJSStringMaybe :: JSContextRef -> JSValueRef -> IO (Maybe String)
112+fromJSStringMaybe c t = do
113+ isNull <- jsvalueisnull c t
114+ case isNull of
115+ True -> return Nothing
116+ False -> do
117+ j <- jsvaluetostringcopy c t nullPtr
118+ l <- jsstringgetmaximumutf8cstringsize j
119+ s <- allocaBytes (fromIntegral l) $ \ps -> do
120+ _ <- jsstringgetutf8cstring'_ j ps (fromIntegral l)
121+ peekCString ps
122+ return $ Just s
123+
124+getLocationHost :: WebView -> IO String
125+getLocationHost wv = withWebViewContext wv $ \c -> do
126+ script <- jsstringcreatewithutf8cstring "location.host"
127+ lh <- jsevaluatescript c script nullPtr nullPtr 1 nullPtr
128+ lh' <- fromJSStringMaybe c lh
129+ return $ maybe "" id lh'
130+
131+getLocationProtocol :: WebView -> IO String
132+getLocationProtocol wv = withWebViewContext wv $ \c -> do
133+ script <- jsstringcreatewithutf8cstring "location.protocol"
134+ lp <- jsevaluatescript c script nullPtr nullPtr 1 nullPtr
135+ lp' <- fromJSStringMaybe c lp
136+ return $ maybe "" id lp'
137+
138+bsToArrayBuffer :: JSContextRef -> ByteString -> IO JSValueRef
139+bsToArrayBuffer c bs = do
140+ elems <- forM (BS.unpack bs) $ \x -> jsvaluemakenumber c $ fromIntegral x
141+ let numElems = length elems
142+ bracket (mallocArray numElems) free $ \elemsArr -> do
143+ pokeArray elemsArr elems
144+ a <- jsobjectmakearray c (fromIntegral numElems) elemsArr nullPtr
145+ newUint8Array <- jsstringcreatewithutf8cstring "new Uint8Array(this)"
146+ jsevaluatescript c newUint8Array a nullPtr 1 nullPtr
147+
148+bsFromArrayBuffer :: JSContextRef -> JSValueRef -> IO ByteString
149+bsFromArrayBuffer c a = do
150+ let getIntegral = fmap round . (\x -> jsvaluetonumber c x nullPtr)
151+ getByteLength <- jsstringcreatewithutf8cstring "this.byteLength"
152+ byteLength <- getIntegral =<< jsevaluatescript c getByteLength a nullPtr 1 nullPtr
153+ toUint8Array <- jsstringcreatewithutf8cstring "new Uint8Array(this)"
154+ uint8Array <- jsevaluatescript c toUint8Array a nullPtr 1 nullPtr
155+ getIx <- jsstringcreatewithutf8cstring "this[0][this[1]]"
156+ let arrayLookup i = do
157+ i' <- jsvaluemakenumber c (fromIntegral i)
158+ args <- toJSObject c [uint8Array, i']
159+ getIntegral =<< jsevaluatescript c getIx args nullPtr 1 nullPtr
160+ fmap BS.pack $ forM [0..byteLength-1] arrayLookup
161+
162+withWebViewContext :: WebView -> (JSContextRef -> IO a) -> IO a
163+withWebViewContext wv f = f =<< webFrameGetGlobalContext =<< webViewGetMainFrame wv
src-ghc/Reflex/Dom/WebSocket/Foreign.hsnew file+70
@@ -0,0 +1,70 @@
1+{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI, CPP, TemplateHaskell, NoMonomorphismRestriction, EmptyDataDecls, RankNTypes, GADTs, RecursiveDo, ScopedTypeVariables, FlexibleInstances, MultiParamTypeClasses, TypeFamilies, FlexibleContexts, DeriveDataTypeable, GeneralizedNewtypeDeriving, StandaloneDeriving, ConstraintKinds, UndecidableInstances, PolyKinds, AllowAmbiguousTypes #-}
2+
3+module Reflex.Dom.WebSocket.Foreign where
4+
5+import Prelude hiding (div, span, mapM, mapM_, concat, concatMap, all, sequence)
6+
7+import Control.Exception
8+import Control.Monad.State
9+import Data.ByteString (ByteString)
10+import Data.Text.Encoding
11+import Foreign.Marshal hiding (void)
12+import Foreign.Ptr
13+import Foreign.Storable
14+import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSBase
15+import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSObjectRef
16+import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSStringRef
17+import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSValueRef
18+import Graphics.UI.Gtk.WebKit.WebView
19+import qualified Data.ByteString as BS
20+import qualified Data.Text as T
21+
22+import Reflex.Dom.Internal.Foreign
23+
24+data JSWebSocket = JSWebSocket { wsValue :: JSValueRef
25+ , wsContext :: JSContextRef
26+ }
27+
28+newWebSocket :: WebView -> String -> (ByteString -> IO ()) -> IO () -> IO () -> IO JSWebSocket
29+newWebSocket wv url onMessage onOpen onClose = withWebViewContext wv $ \c -> do
30+ url' <- jsvaluemakestring c =<< jsstringcreatewithutf8cstring url
31+ newWSArgs <- toJSObject c [url']
32+ newWS <- jsstringcreatewithutf8cstring "(function(that) { var ws = new WebSocket(that[0]); ws['binaryType'] = 'arraybuffer'; return ws; })(this)"
33+ ws <- jsevaluatescript c newWS newWSArgs nullPtr 1 nullPtr
34+ onMessage' <- wrapper $ \_ _ _ _ args _ -> do
35+ e <- peekElemOff args 0
36+ dataProp <- jsstringcreatewithutf8cstring "data"
37+ msg <- jsobjectgetproperty c e dataProp nullPtr
38+ msg' <- fromJSStringMaybe c msg
39+ case msg' of
40+ Nothing -> return ()
41+ Just m -> onMessage $ encodeUtf8 $ T.pack m
42+ jsvaluemakeundefined c
43+ onMessageCb <- jsobjectmakefunctionwithcallback c nullPtr onMessage'
44+ onOpen' <- wrapper $ \_ _ _ _ _ _ -> do
45+ onOpen
46+ jsvaluemakeundefined c
47+ onOpenCb <- jsobjectmakefunctionwithcallback c nullPtr onOpen'
48+ onClose' <- wrapper $ \_ _ _ _ _ _ -> do
49+ onClose
50+ jsvaluemakeundefined c
51+ onCloseCb <- jsobjectmakefunctionwithcallback c nullPtr onClose'
52+ o <- toJSObject c [ws, onMessageCb, onOpenCb, onCloseCb]
53+ addCbs <- jsstringcreatewithutf8cstring "this[0]['onmessage'] = this[1]; this[0]['onopen'] = this[2]; this[0]['onclose'] = this[3];"
54+ _ <- jsevaluatescript c addCbs o nullPtr 1 nullPtr
55+ return $ JSWebSocket ws c
56+
57+webSocketSend :: JSWebSocket -> ByteString -> IO ()
58+webSocketSend (JSWebSocket ws c) bs = do
59+ elems <- forM (BS.unpack bs) $ \x -> jsvaluemakenumber c $ fromIntegral x
60+ let numElems = length elems
61+ bs' <- bracket (mallocArray numElems) free $ \elemsArr -> do
62+ pokeArray elemsArr elems
63+ a <- jsobjectmakearray c (fromIntegral numElems) elemsArr nullPtr
64+ newUint8Array <- jsstringcreatewithutf8cstring "new Uint8Array(this)"
65+ jsevaluatescript c newUint8Array a nullPtr 1 nullPtr
66+ send <- jsstringcreatewithutf8cstring "this[0]['send'](String['fromCharCode']['apply'](null, this[1]))"
67+ sendArgs <- toJSObject c [ws, bs']
68+ _ <- jsevaluatescript c send sendArgs nullPtr 1 nullPtr
69+ return ()
70+
src-ghc/Reflex/Dom/Xhr/Foreign.hs+101−50
@@ -1,7 +1,8 @@
1−{-# LANGUAGE ForeignFunctionInterface #-}
1+{-# LANGUAGE QuasiQuotes, ForeignFunctionInterface #-}
2+
23module Reflex.Dom.Xhr.Foreign where
34
4−import Control.Lens.Indexed
5+import Control.Monad
56import qualified Data.Text as T
67import Data.Text (Text)
78import System.Glib.FFI
@@ -10,7 +11,15 @@ import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSBase
1011import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSObjectRef
1112import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSStringRef
1213import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSValueRef
13−import Graphics.UI.Gtk.WebKit.JavaScriptCore.WebFrame
14+import Reflex.Dom.Xhr.ResponseType
15+import Reflex.Dom.Xhr.Exception
16+import Control.Concurrent.MVar
17+import Control.Exception.Base
18+import Graphics.UI.Gtk.WebKit.Types hiding (Text)
19+
20+import Reflex.Dom.Internal.Foreign
21+
22+import Text.RawString.QQ
1423
1524data XMLHttpRequest
1625 = XMLHttpRequest { xhrValue :: JSValueRef
@@ -18,30 +27,24 @@ data XMLHttpRequest
1827 }
1928 deriving (Eq, Ord)
2029
21−toJSObject :: JSContextRef -> [Ptr OpaqueJSValue] -> IO JSObjectRef
22−toJSObject ctx args = do
23− o <- jsobjectmake ctx nullPtr nullPtr
24− iforM_ args $ \n a -> do
25− prop <- jsstringcreatewithutf8cstring $ show n
26− jsobjectsetproperty ctx o prop a 1 nullPtr
27− return o
28−
29−responseTextToText :: Maybe String -> Maybe Text
30−responseTextToText = fmap T.pack
31−
32−statusTextToText :: String -> Text
33−statusTextToText = T.pack
34−
3530stringToJSValue :: JSContextRef -> String -> IO JSValueRef
3631stringToJSValue ctx s = jsvaluemakestring ctx =<< jsstringcreatewithutf8cstring s
3732
38−toResponseType :: a -> a
39−toResponseType = id
33+fromResponseType :: XhrResponseType -> String
34+fromResponseType XhrResponseType_Default = ""
35+fromResponseType XhrResponseType_ArrayBuffer = "arraybuffer"
36+fromResponseType XhrResponseType_Blob = "blob"
37+fromResponseType XhrResponseType_Text = "text"
38+
39+toResponseType :: String -> Maybe XhrResponseType
40+toResponseType "" = Just XhrResponseType_Default
41+toResponseType "arraybuffer" = Just XhrResponseType_ArrayBuffer
42+toResponseType "blob" = Just XhrResponseType_Blob
43+toResponseType "text" = Just XhrResponseType_Text
44+toResponseType _ = Nothing
4045
4146xmlHttpRequestNew :: WebView -> IO XMLHttpRequest
42−xmlHttpRequestNew wv = do
43− wf <- webViewGetMainFrame wv
44− jsContext <- webFrameGetGlobalContext wf
47+xmlHttpRequestNew wv = withWebViewContext wv $ \jsContext -> do
4548 xhrScript <- jsstringcreatewithutf8cstring "new XMLHttpRequest()"
4649 xhr' <- jsevaluatescript jsContext xhrScript nullPtr nullPtr 1 nullPtr
4750 jsvalueprotect jsContext xhr'
@@ -60,9 +63,6 @@ xmlHttpRequestOpen xhr method url async user password = do
6063 _ <- jsevaluatescript c script o nullPtr 1 nullPtr
6164 return ()
6265
63−foreign import ccall "wrapper"
64− wrapper :: JSObjectCallAsFunctionCallback' -> IO JSObjectCallAsFunctionCallback
65−
6666xmlHttpRequestOnreadystatechange :: XMLHttpRequest -> IO () -> IO ()
6767xmlHttpRequestOnreadystatechange xhr userCallback = do
6868 let c = xhrContext xhr
@@ -83,38 +83,89 @@ xmlHttpRequestGetReadyState xhr = do
8383 d <- jsvaluetonumber c rs nullPtr
8484 return $ truncate d
8585
86−xmlHttpRequestGetResponseText :: XMLHttpRequest -> IO (Maybe String)
87−xmlHttpRequestGetResponseText xhr = do
86+xmlHttpRequestGetResponseType :: XMLHttpRequest -> IO (Maybe XhrResponseType)
87+xmlHttpRequestGetResponseType xhr = do
88+ script <- jsstringcreatewithutf8cstring "this.responseType"
89+ rt <- jsevaluatescript (xhrContext xhr) script (xhrValue xhr) nullPtr 1 nullPtr
90+ ms <- fromJSStringMaybe (xhrContext xhr) rt
91+ return $ join $ fmap toResponseType ms
92+
93+xmlHttpRequestGetResponse :: XMLHttpRequest -> IO (Maybe XhrResponseBody)
94+xmlHttpRequestGetResponse xhr = do
8895 let c = xhrContext xhr
89− script <- jsstringcreatewithutf8cstring "this.responseText"
96+ mrt <- xmlHttpRequestGetResponseType xhr
97+ script <- jsstringcreatewithutf8cstring "this.response"
9098 t <- jsevaluatescript c script (xhrValue xhr) nullPtr 1 nullPtr
9199 isNull <- jsvalueisnull c t
92100 case isNull of
93101 True -> return Nothing
94− False -> do
95− j <- jsvaluetostringcopy c t nullPtr
96− l <- jsstringgetmaximumutf8cstringsize j
97− s <- allocaBytes (fromIntegral l) $ \ps -> do
98− _ <- jsstringgetutf8cstring'_ j ps (fromIntegral l)
99− peekCString ps
100− return $ Just s
102+ False -> case mrt of
103+ Just XhrResponseType_ArrayBuffer -> Just . XhrResponseBody_ArrayBuffer <$> bsFromArrayBuffer c t
104+ Just XhrResponseType_Blob -> Just . XhrResponseBody_Blob . Blob . castForeignPtr <$> newForeignPtr_ t
105+ Just XhrResponseType_Default -> fmap (XhrResponseBody_Default . T.pack) <$> fromJSStringMaybe c t
106+ Just XhrResponseType_Text -> fmap (XhrResponseBody_Text . T.pack) <$> fromJSStringMaybe c t
107+ _ -> return Nothing
108+
109+xmlHttpRequestGetResponseText :: XMLHttpRequest -> IO (Maybe Text)
110+xmlHttpRequestGetResponseText xhr = do
111+ let c = xhrContext xhr
112+ script <- jsstringcreatewithutf8cstring "this.responseText"
113+ t <- jsevaluatescript c script (xhrValue xhr) nullPtr 1 nullPtr
114+ fmap (fmap T.pack) $ fromJSStringMaybe c t
101115
102116xmlHttpRequestSend :: XMLHttpRequest -> Maybe String -> IO ()
103117xmlHttpRequestSend xhr payload = do
104118 let c = xhrContext xhr
105− (o,s) <- case payload of
106− Nothing -> do
107− o <- toJSObject c [xhrValue xhr]
108− s <- jsstringcreatewithutf8cstring "this[0].send();"
109− return (o,s)
110− Just payload' -> do
111− d <- stringToJSValue c payload'
112− o <- toJSObject c [xhrValue xhr, d]
113− s <- jsstringcreatewithutf8cstring "this[0].send(this[1])"
114− return (o,s)
115− _ <- jsevaluatescript c s o nullPtr 1 nullPtr
116− return ()
117−
119+ result <- newEmptyMVar
120+ let wrapper' x = wrapper $ \_ _ _ _ _ _ -> putMVar result x >> jsvaluemakeundefined c
121+ bracket (wrapper' $ Just XhrException_Aborted) freeHaskellFunPtr $ \a -> do
122+ onAbort <- jsobjectmakefunctionwithcallback c nullPtr a
123+ bracket (wrapper' $ Just XhrException_Error) freeHaskellFunPtr $ \e -> do
124+ onError <- jsobjectmakefunctionwithcallback c nullPtr e
125+ bracket (wrapper' Nothing) freeHaskellFunPtr $ \l -> do
126+ onLoad <- jsobjectmakefunctionwithcallback c nullPtr l
127+ (o,s) <- case payload of
128+ Nothing -> do
129+ d <- jsvaluemakeundefined c
130+ o <- toJSObject c [xhrValue xhr, d, onError, onAbort, onLoad]
131+ s <- jsstringcreatewithutf8cstring send
132+ return (o,s)
133+ Just payload' -> do
134+ d <- stringToJSValue c payload'
135+ o <- toJSObject c [xhrValue xhr, d, onError, onAbort, onLoad]
136+ s <- jsstringcreatewithutf8cstring send
137+ return (o,s)
138+ _ <- jsevaluatescript c s o nullPtr 1 nullPtr
139+ takeMVar result >>= mapM_ throwIO
140+ where
141+ send = [r|
142+ (function (xhr, d, onError, onAbort, onLoad) {
143+ var clear;
144+ var error = function () {
145+ clear(); onError();
146+ };
147+ var abort = function () {
148+ clear(); onAbort();
149+ };
150+ var load = function () {
151+ clear(); onLoad();
152+ };
153+ clear = function () {
154+ xhr.removeEventListener('error', error);
155+ xhr.removeEventListener('abort', abort);
156+ xhr.removeEventListener('load', load);
157+ }
158+ xhr.addEventListener('error', error);
159+ xhr.addEventListener('abort', abort);
160+ xhr.addEventListener('load', load);
161+ if(d) {
162+ xhr.send(d);
163+ } else {
164+ xhr.send();
165+ }
166+ })(this[0], this[1], this[2], this[3], this[4])
167+ |]
168+
118169xmlHttpRequestSetRequestHeader :: XMLHttpRequest -> String -> String -> IO ()
119170xmlHttpRequestSetRequestHeader xhr header value = do
120171 let c = xhrContext xhr
@@ -142,7 +193,7 @@ xmlHttpRequestGetStatus xhr = do
142193 d <- jsvaluetonumber c s nullPtr
143194 return $ truncate d
144195
145−xmlHttpRequestGetStatusText :: XMLHttpRequest -> IO String
196+xmlHttpRequestGetStatusText :: XMLHttpRequest -> IO Text
146197xmlHttpRequestGetStatusText xhr = do
147198 let c = xhrContext xhr
148199 script <- jsstringcreatewithutf8cstring "this.statusText"
@@ -152,4 +203,4 @@ xmlHttpRequestGetStatusText xhr = do
152203 s <- allocaBytes (fromIntegral l) $ \ps -> do
153204 _ <- jsstringgetutf8cstring'_ j ps (fromIntegral l)
154205 peekCString ps
155− return s
206+ return $ T.pack s
src-ghcjs/Reflex/Dom/Internal/Foreign.hs+38−4
@@ -1,9 +1,43 @@
1−module Reflex.Dom.Internal.Foreign (runWebGUI) where
1+{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI #-}
2+module Reflex.Dom.Internal.Foreign ( module Reflex.Dom.Internal.Foreign
3+ , runWebGUI
4+ ) where
25
6+import Control.Monad
7+import Data.ByteString (ByteString)
8+import Foreign
9+import Foreign.C
310import GHCJS.DOM
411import GHCJS.DOM.Types
512import GHCJS.Types
6−import Data.Function
13+import JavaScript.TypedArray.ArrayBuffer as JS
14+import qualified Data.ByteString as BS
15+import qualified GHCJS.Buffer as JS
16+import qualified GHCJS.Marshal.Pure as JS
717
8−instance Eq Node where
9− (==) = eqRef `on` unNode
18+quitWebView :: WebView -> IO ()
19+quitWebView = error "quitWebView: unimplemented in GHCJS"
20+
21+foreign import javascript unsafe "location['host']" getLocationHost_ :: IO JSString
22+
23+getLocationHost :: FromJSString r => a -> IO r
24+getLocationHost _ = liftM fromJSString getLocationHost_
25+
26+foreign import javascript unsafe "location['protocol']" getLocationProtocol_ :: IO JSString
27+
28+getLocationProtocol :: FromJSString r => a -> IO r
29+getLocationProtocol _ = liftM fromJSString getLocationProtocol_
30+
31+withWebViewContext :: a -> (a -> IO b) -> IO b
32+withWebViewContext a f = f a
33+
34+foreign import javascript safe "new DataView($3,$1,$2)" js_dataView :: Int -> Int -> JSVal -> JSVal
35+
36+foreign import javascript unsafe "new Uint8Array($1_1['buf'], $1_2, $2)['buffer']" extractByteArray :: Ptr CChar -> Int -> IO JSVal
37+
38+bsToArrayBuffer :: a -> ByteString -> IO JSVal
39+bsToArrayBuffer _ bs = BS.useAsCString bs $ \cStr -> do
40+ extractByteArray cStr $ BS.length bs
41+
42+bsFromArrayBuffer :: a -> JSVal -> IO ByteString
43+bsFromArrayBuffer _ ab = liftM (JS.toByteString 0 Nothing . JS.createFromArrayBuffer) $ JS.unsafeFreeze $ JS.pFromJSVal ab
src-ghcjs/Reflex/Dom/WebSocket/Foreign.hsnew file+44
@@ -0,0 +1,44 @@
1+{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI, CPP #-}
2+
3+module Reflex.Dom.WebSocket.Foreign where
4+
5+import Prelude hiding (div, span, mapM, mapM_, concat, concatMap, all, sequence)
6+
7+import Data.ByteString (ByteString)
8+import qualified Data.ByteString as BS
9+import GHCJS.Types
10+import GHCJS.DOM.WebSocket (message, open, closeEvent)
11+import qualified GHCJS.DOM.WebSocket as GD
12+import GHCJS.DOM.MessageEvent
13+import GHCJS.DOM.EventM (on)
14+import GHCJS.DOM.Types
15+import Control.Monad.IO.Class
16+import Control.Monad.Reader
17+import GHCJS.Buffer
18+import JavaScript.TypedArray.ArrayBuffer as JS
19+import GHCJS.Marshal.Pure
20+
21+data JSWebSocket = JSWebSocket { unWebSocket :: WebSocket }
22+
23+newWebSocket :: a -> String -> (ByteString -> IO ()) -> IO () -> IO () -> IO JSWebSocket
24+newWebSocket _ url onMessage onOpen onClose = do
25+ ws <- GD.newWebSocket url (Just [] :: Maybe [String])
26+ _ <- on ws open $ liftIO onOpen
27+ GD.setBinaryType ws "arraybuffer"
28+ _ <- on ws message $ do
29+ e <- ask
30+ d <- getData e
31+ ab <- liftIO $ unsafeFreeze $ pFromJSVal d
32+ liftIO $ onMessage $ toByteString 0 Nothing $ createFromArrayBuffer ab
33+ _ <- on ws closeEvent $ liftIO onClose
34+ return $ JSWebSocket ws
35+
36+webSocketSend :: JSWebSocket -> ByteString -> IO ()
37+webSocketSend (JSWebSocket ws) bs = do
38+ let (b, off, len) = fromByteString bs
39+ ab <- ArrayBuffer <$> if BS.length bs == 0 --TODO: remove this logic when https://github.com/ghcjs/ghcjs-base/issues/49 is fixed
40+ then jsval . getArrayBuffer <$> create 0
41+ else return $ js_dataView off len $ jsval $ getArrayBuffer b
42+ GD.send ws $ Just ab
43+
44+foreign import javascript safe "new DataView($3,$1,$2)" js_dataView :: Int -> Int -> JSVal -> JSVal
src-ghcjs/Reflex/Dom/Xhr/Foreign.hs+117−365
@@ -1,399 +1,151 @@
1−{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI #-}
1+{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI, OverloadedStrings #-}
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)
18+import Reflex.Dom.Internal.Foreign
19+import Reflex.Dom.Xhr.Exception
20+import Reflex.Dom.Xhr.ResponseType
21+import Control.Exception (catch, throwIO)
1622
1723prepareWebView :: WebView -> IO ()
1824prepareWebView _ = return ()
1925
20−foreign import javascript unsafe "h$isInstanceOf $1 $2"
21− typeInstanceIsA' :: JSRef a -> JSRef GType -> Bool
26+xmlHttpRequestNew :: a -> IO XMLHttpRequest
27+xmlHttpRequestNew _ = newXMLHttpRequest
2228
23−typeInstanceIsA :: JSRef a -> GType -> Bool
24−typeInstanceIsA o (GType t) = typeInstanceIsA' o t
29+xmlHttpRequestOpen ::
30+ (ToJSString method, ToJSString url, ToJSString user, ToJSString password) =>
31+ XMLHttpRequest -> method -> url -> Bool -> user -> password -> IO ()
32+xmlHttpRequestOpen = open
2533
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
34+convertException :: XHRError -> XhrException
35+convertException e = case e of
36+ XHRError -> XhrException_Error
37+ XHRAborted -> XhrException_Aborted
3438
39+-- This used to be a non blocking call, but now it uses an interruptible ffi
40+xmlHttpRequestSend :: ToJSString payload => XMLHttpRequest -> Maybe payload -> IO ()
41+xmlHttpRequestSend self p = (maybe (send self) (sendString self) p) `catch` (throwIO . convertException)
3542
36−newtype XMLHttpRequest = XMLHttpRequest { unXMLHttpRequest :: JSRef XMLHttpRequest }
43+xmlHttpRequestSetRequestHeader :: (ToJSString header, ToJSString value)
44+ => XMLHttpRequest -> header -> value -> IO ()
45+xmlHttpRequestSetRequestHeader = setRequestHeader
3746
38−instance Eq XMLHttpRequest where
39− (==) = eqRef `on` unXMLHttpRequest
47+xmlHttpRequestAbort :: XMLHttpRequest -> IO ()
48+xmlHttpRequestAbort = abort
4049
41−instance ToJSRef XMLHttpRequest where
42− toJSRef = return . unXMLHttpRequest
43− {-# INLINE toJSRef #-}
50+xmlHttpRequestGetAllResponseHeaders :: XMLHttpRequest -> IO Text
51+xmlHttpRequestGetAllResponseHeaders self = fromMaybe "" <$> getAllResponseHeaders self
4452
45−instance FromJSRef XMLHttpRequest where
46− fromJSRef = return . fmap XMLHttpRequest . maybeJSNull
47− {-# INLINE fromJSRef #-}
53+xmlHttpRequestGetResponseHeader :: (ToJSString header)
54+ => XMLHttpRequest -> header -> IO Text
55+xmlHttpRequestGetResponseHeader self header = fromMaybe "" <$> getResponseHeader self header
4856
49−class GObjectClass o => IsXMLHttpRequest o
50−toXMLHttpRequest :: IsXMLHttpRequest o => o -> XMLHttpRequest
51−toXMLHttpRequest = unsafeCastGObject . toGObject
57+xmlHttpRequestOverrideMimeType :: ToJSString override => XMLHttpRequest -> override -> IO ()
58+xmlHttpRequestOverrideMimeType = overrideMimeType
5259
53−instance IsXMLHttpRequest XMLHttpRequest
54−instance GObjectClass XMLHttpRequest where
55− toGObject = GObject . castRef . unXMLHttpRequest
56− unsafeCastGObject = XMLHttpRequest . castRef . unGObject
60+xmlHttpRequestDispatchEvent :: IsEvent evt => XMLHttpRequest -> Maybe evt -> IO Bool
61+xmlHttpRequestDispatchEvent = dispatchEvent
5762
58−castToXMLHttpRequest :: GObjectClass obj => obj -> XMLHttpRequest
59−castToXMLHttpRequest = castTo gTypeXMLHttpRequest "XMLHttpRequest"
63+xmlHttpRequestOnabort :: XMLHttpRequest -> EventM XMLHttpRequest XMLHttpRequestProgressEvent () -> IO (IO ())
64+xmlHttpRequestOnabort = (`on` abortEvent)
6065
61−foreign import javascript unsafe "window[\"XMLHttpRequest\"]" gTypeXMLHttpRequest' :: JSRef GType
62−gTypeXMLHttpRequest :: GType
63−gTypeXMLHttpRequest = GType gTypeXMLHttpRequest'
66+xmlHttpRequestOnerror :: XMLHttpRequest -> EventM XMLHttpRequest XMLHttpRequestProgressEvent () -> IO (IO ())
67+xmlHttpRequestOnerror = (`on` error)
6468
69+xmlHttpRequestOnload :: XMLHttpRequest -> EventM XMLHttpRequest XMLHttpRequestProgressEvent () -> IO (IO ())
70+xmlHttpRequestOnload = (`on` load)
6571
66−newtype XMLHttpRequestUpload = XMLHttpRequestUpload { unXMLHttpRequestUpload :: JSRef XMLHttpRequestUpload }
72+xmlHttpRequestOnloadend :: XMLHttpRequest -> EventM XMLHttpRequest ProgressEvent () -> IO (IO ())
73+xmlHttpRequestOnloadend = (`on` loadEnd)
6774
68−instance Eq XMLHttpRequestUpload where
69− (==) = eqRef `on` unXMLHttpRequestUpload
75+xmlHttpRequestOnloadstart :: XMLHttpRequest -> EventM XMLHttpRequest ProgressEvent () -> IO (IO ())
76+xmlHttpRequestOnloadstart = (`on` loadStart)
7077
71−instance ToJSRef XMLHttpRequestUpload where
72− toJSRef = return . unXMLHttpRequestUpload
73− {-# INLINE toJSRef #-}
78+xmlHttpRequestOnprogress :: XMLHttpRequest -> EventM XMLHttpRequest XMLHttpRequestProgressEvent () -> IO (IO ())
79+xmlHttpRequestOnprogress = (`on` progress)
7480
75−instance FromJSRef XMLHttpRequestUpload where
76− fromJSRef = return . fmap XMLHttpRequestUpload . maybeJSNull
77− {-# INLINE fromJSRef #-}
81+xmlHttpRequestOntimeout :: XMLHttpRequest -> EventM XMLHttpRequest ProgressEvent () -> IO (IO ())
82+xmlHttpRequestOntimeout = (`on` timeout)
7883
79−class GObjectClass o => IsXMLHttpRequestUpload o
80−toXMLHttpRequestUpload :: IsXMLHttpRequestUpload o => o -> XMLHttpRequestUpload
81−toXMLHttpRequestUpload = unsafeCastGObject . toGObject
84+xmlHttpRequestOnreadystatechange :: XMLHttpRequest -> EventM XMLHttpRequest Event () -> IO (IO ())
85+xmlHttpRequestOnreadystatechange = (`on` readyStateChange)
8286
83−instance IsXMLHttpRequestUpload XMLHttpRequestUpload
84−instance GObjectClass XMLHttpRequestUpload where
85− toGObject = GObject . castRef . unXMLHttpRequestUpload
86− unsafeCastGObject = XMLHttpRequestUpload . castRef . unGObject
87+xmlHttpRequestSetTimeout :: XMLHttpRequest -> Word -> IO ()
88+xmlHttpRequestSetTimeout = setTimeout
8789
88−castToXMLHttpRequestUpload :: GObjectClass obj => obj -> XMLHttpRequestUpload
89−castToXMLHttpRequestUpload = castTo gTypeXMLHttpRequestUpload "XMLHttpRequestUpload"
90+xmlHttpRequestGetTimeout :: XMLHttpRequest -> IO Word
91+xmlHttpRequestGetTimeout = getTimeout
9092
91−foreign import javascript unsafe "window[\"XMLHttpRequestUpload\"]" gTypeXMLHttpRequestUpload' :: JSRef GType
92−gTypeXMLHttpRequestUpload :: GType
93−gTypeXMLHttpRequestUpload = GType gTypeXMLHttpRequestUpload'
93+xmlHttpRequestGetReadyState :: XMLHttpRequest -> IO Word
94+xmlHttpRequestGetReadyState = getReadyState
9495
95−foreign import javascript unsafe "new XMLHttpRequest()"
96− ghcjs_dom_xml_http_request_new ::
97− IO (JSRef XMLHttpRequest)
96+xmlHttpRequestSetWithCredentials :: XMLHttpRequest -> Bool -> IO ()
97+xmlHttpRequestSetWithCredentials = setWithCredentials
9898
99−xmlHttpRequestNew :: a -> IO XMLHttpRequest
100−xmlHttpRequestNew _ = XMLHttpRequest <$> ghcjs_dom_xml_http_request_new
99+xmlHttpRequestGetWithCredentials :: XMLHttpRequest -> IO Bool
100+xmlHttpRequestGetWithCredentials = getWithCredentials
101101
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 ()
102+xmlHttpRequestGetUpload :: XMLHttpRequest -> IO (Maybe XMLHttpRequestUpload)
103+xmlHttpRequestGetUpload = getUpload
105104
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
328−
329−statusTextToText :: Text -> Text
330−statusTextToText = id
331−
332−foreign import javascript unsafe "$1[\"responseXML\"]"
333− ghcjs_dom_xml_http_request_get_response_xml ::
334− JSRef XMLHttpRequest -> IO (JSRef Document)
335−
336−xmlHttpRequestGetResponseXML ::
337− (IsXMLHttpRequest self) => self -> IO (Maybe Document)
338−xmlHttpRequestGetResponseXML self
339− = fmap Document . maybeJSNull <$>
340− (ghcjs_dom_xml_http_request_get_response_xml
341− (unXMLHttpRequest (toXMLHttpRequest self)))
342−
343−foreign import javascript unsafe "$1[\"responseType\"] = $2;"
344− ghcjs_dom_xml_http_request_set_response_type ::
345− JSRef XMLHttpRequest -> JSString -> IO ()
346−
347−xmlHttpRequestSetResponseType ::
348− (IsXMLHttpRequest self, ToJSString val) => self -> val -> IO ()
349−xmlHttpRequestSetResponseType self val
350− = ghcjs_dom_xml_http_request_set_response_type
351− (unXMLHttpRequest (toXMLHttpRequest self))
352− (toJSString val)
353−
354−toResponseType :: (ToJSString a) => a -> JSString
355−toResponseType = toJSString
356−
357−foreign import javascript unsafe "$1[\"responseType\"]"
358− ghcjs_dom_xml_http_request_get_response_type ::
359− JSRef XMLHttpRequest -> IO JSString
360−
361−xmlHttpRequestGetResponseType ::
362− (IsXMLHttpRequest self, FromJSString result) => self -> IO result
363−xmlHttpRequestGetResponseType self
364− = fromJSString <$>
365− (ghcjs_dom_xml_http_request_get_response_type
366− (unXMLHttpRequest (toXMLHttpRequest self)))
367−
368−foreign import javascript unsafe "$1[\"status\"]"
369− ghcjs_dom_xml_http_request_get_status ::
370− JSRef XMLHttpRequest -> IO Word
371−
372−xmlHttpRequestGetStatus ::
373− (IsXMLHttpRequest self) => self -> IO Word
374−xmlHttpRequestGetStatus self
375− = ghcjs_dom_xml_http_request_get_status
376− (unXMLHttpRequest (toXMLHttpRequest self))
377−
378−foreign import javascript unsafe "$1[\"statusText\"]"
379− ghcjs_dom_xml_http_request_get_status_text ::
380− JSRef XMLHttpRequest -> IO JSString
381−
382−xmlHttpRequestGetStatusText ::
383− (IsXMLHttpRequest self, FromJSString result) => self -> IO result
384−xmlHttpRequestGetStatusText self
385− = fromJSString <$>
386− (ghcjs_dom_xml_http_request_get_status_text
387− (unXMLHttpRequest (toXMLHttpRequest self)))
388−
389−foreign import javascript unsafe "$1[\"responseURL\"]"
390− ghcjs_dom_xml_http_request_get_response_url ::
391− JSRef XMLHttpRequest -> IO JSString
392−
393−xmlHttpRequestGetResponseURL ::
394− (IsXMLHttpRequest self, FromJSString result) => self -> IO result
395−xmlHttpRequestGetResponseURL self
396− = fromJSString <$>
397− (ghcjs_dom_xml_http_request_get_response_url
398− (unXMLHttpRequest (toXMLHttpRequest self)))
105+xmlHttpRequestGetResponseText :: FromJSString result => XMLHttpRequest -> IO (Maybe result)
106+xmlHttpRequestGetResponseText = getResponseText
107+
108+xmlHttpRequestGetResponseXML :: XMLHttpRequest -> IO (Maybe Document)
109+xmlHttpRequestGetResponseXML = getResponseXML
110+
111+xmlHttpRequestSetResponseType :: XMLHttpRequest -> XMLHttpRequestResponseType -> IO ()
112+xmlHttpRequestSetResponseType = setResponseType
113+
114+fromResponseType :: XhrResponseType -> XMLHttpRequestResponseType
115+fromResponseType XhrResponseType_Default = XMLHttpRequestResponseType
116+fromResponseType XhrResponseType_ArrayBuffer = XMLHttpRequestResponseTypeArraybuffer
117+fromResponseType XhrResponseType_Blob = XMLHttpRequestResponseTypeBlob
118+fromResponseType XhrResponseType_Text = XMLHttpRequestResponseTypeText
119+
120+toResponseType :: XMLHttpRequestResponseType -> Maybe XhrResponseType
121+toResponseType XMLHttpRequestResponseType = Just XhrResponseType_Default
122+toResponseType XMLHttpRequestResponseTypeArraybuffer = Just XhrResponseType_ArrayBuffer
123+toResponseType XMLHttpRequestResponseTypeBlob = Just XhrResponseType_Blob
124+toResponseType XMLHttpRequestResponseTypeText = Just XhrResponseType_Text
125+toResponseType _ = Nothing
126+
127+xmlHttpRequestGetResponseType :: XMLHttpRequest -> IO (Maybe XhrResponseType)
128+xmlHttpRequestGetResponseType = fmap toResponseType . getResponseType
129+
130+xmlHttpRequestGetStatus :: XMLHttpRequest -> IO Word
131+xmlHttpRequestGetStatus = getStatus
132+
133+xmlHttpRequestGetStatusText :: FromJSString result => XMLHttpRequest -> IO result
134+xmlHttpRequestGetStatusText = getStatusText
135+
136+xmlHttpRequestGetResponseURL :: FromJSString result => XMLHttpRequest -> IO result
137+xmlHttpRequestGetResponseURL = getResponseURL
138+
139+xmlHttpRequestGetResponse :: XMLHttpRequest -> IO (Maybe XhrResponseBody)
140+xmlHttpRequestGetResponse xhr = do
141+ mr <- getResponse xhr
142+ rt <- xmlHttpRequestGetResponseType xhr
143+ case rt of
144+ Just XhrResponseType_Blob -> return $ fmap (XhrResponseBody_Blob . castToBlob) mr
145+ Just XhrResponseType_Text -> fmap (Just . XhrResponseBody_Text) $ xmlHttpRequestGetStatusText xhr
146+ Just XhrResponseType_Default -> fmap (Just . XhrResponseBody_Text) $ xmlHttpRequestGetStatusText xhr
147+ Just XhrResponseType_ArrayBuffer -> case (fmap unGObject mr) of
148+ Nothing -> return Nothing
149+ Just ptr -> fmap (Just . XhrResponseBody_ArrayBuffer) $ bsFromArrayBuffer ptr ptr
150+ _ -> return Nothing
399151
src/Reflex/Dom.hs+4
@@ -5,6 +5,8 @@ module Reflex.Dom ( module Reflex
55 , module Reflex.Dom.Xhr
66 , module Reflex.Dom.Time
77 , module Reflex.Dom.DynamicWriter
8+ , module Reflex.Dom.WebSocket
9+ , module Reflex.Dom.Location
810 ) where
911
1012import Reflex
@@ -14,3 +16,5 @@ import Reflex.Dom.Widget
1416import Reflex.Dom.Xhr
1517import Reflex.Dom.Time
1618import Reflex.Dom.DynamicWriter
19+import Reflex.Dom.WebSocket
20+import Reflex.Dom.Location
src/Reflex/Dom/Class.hs+3−3
@@ -89,13 +89,13 @@ instance MonadIORestore m => MonadIORestore (ReaderT r m) where
8989
9090class (MonadRef h, Ref h ~ Ref m, MonadRef m) => HasPostGui t h m | m -> t h where
9191 askPostGui :: m (h () -> IO ())
92− askRunWithActions :: m ([DSum (EventTrigger t)] -> h ())
92+ askRunWithActions :: m ([DSum (EventTrigger t) Identity] -> h ())
9393
9494runFrameWithTriggerRef :: (HasPostGui t h m, MonadRef m, MonadIO m) => Ref m (Maybe (EventTrigger t a)) -> a -> m ()
9595runFrameWithTriggerRef r a = do
9696 postGui <- askPostGui
9797 runWithActions <- askRunWithActions
98− liftIO . postGui $ mapM_ (\t -> runWithActions [t :=> a]) =<< readRef r
98+ liftIO . postGui $ mapM_ (\t -> runWithActions [t :=> Identity a]) =<< readRef r
9999
100100instance HasPostGui t h m => HasPostGui t h (ReaderT r m) where
101101 askPostGui = lift askPostGui
@@ -148,7 +148,7 @@ performEventAsync e = do
148148 addVoidAction $ ffor e $ \o -> do
149149 postGui <- askPostGui
150150 runWithActions <- askRunWithActions
151− o $ \a -> postGui $ mapM_ (\t -> runWithActions [t :=> a]) =<< readRef reResultTrigger
151+ o $ \a -> postGui $ mapM_ (\t -> runWithActions [t :=> Identity a]) =<< readRef reResultTrigger
152152 return eResult
153153
154154getPostBuild :: MonadWidget t m => m (Event t ())
src/Reflex/Dom/Internal.hs+16−12
@@ -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
@@ -33,7 +33,7 @@ import Data.Monoid ((<>))
3333data GuiEnv t h
3434 = GuiEnv { _guiEnvDocument :: !HTMLDocument
3535 , _guiEnvPostGui :: !(h () -> IO ())
36− , _guiEnvRunWithActions :: !([DSum (EventTrigger t)] -> h ())
36+ , _guiEnvRunWithActions :: !([DSum (EventTrigger t) Identity] -> h ())
3737 , _guiEnvWebView :: !WebView
3838 }
3939
@@ -162,6 +162,10 @@ instance ( MonadRef m, Ref m ~ Ref IO, MonadRef h, Ref h ~ Ref IO --TODO: Should
162162-- runWidget :: (Monad m, IsNode n, Reflex t) => n -> Widget t m a -> m (a, Event t (m ()))
163163 getRunWidget = return runWidget
164164
165+getQuitWidget :: MonadWidget t m => m (WidgetHost m ())
166+getQuitWidget = return $ do wv <- askWebView
167+ liftIO $ quitWebView wv
168+
165169runWidget :: (Monad m, Reflex t, IsNode n) => n -> Widget t (Gui t h m) a -> WidgetHost (Widget t (Gui t h m)) (a, WidgetHost (Widget t (Gui t h m)) (), Event t (WidgetHost (Widget t (Gui t h m)) ()))
166170runWidget rootElement w = do
167171 (result, WidgetState postBuild voidActions) <- runStateT (runReaderT (unWidget w) (WidgetEnv $ toNode rootElement)) (WidgetState (return ()) [])
@@ -179,23 +183,23 @@ holdOnStartup a0 ma = do
179183mainWidget :: Widget Spider (Gui Spider (WithWebView SpiderHost) (HostFrame Spider)) () -> IO ()
180184mainWidget w = runWebGUI $ \webView -> do
181185 Just doc <- liftM (fmap castToHTMLDocument) $ webViewGetDomDocument webView
182− Just body <- documentGetBody doc
186+ Just body <- getBody doc
183187 attachWidget body webView w
184188
185189mainWidgetWithHead :: Widget Spider (Gui Spider (WithWebView SpiderHost) (HostFrame Spider)) () -> Widget Spider (Gui Spider (WithWebView SpiderHost) (HostFrame Spider)) () -> IO ()
186190mainWidgetWithHead h b = runWebGUI $ \webView -> do
187191 Just doc <- liftM (fmap castToHTMLDocument) $ webViewGetDomDocument webView
188− Just headElement <- liftM (fmap castToHTMLElement) $ documentGetHead doc
192+ Just headElement <- liftM (fmap castToHTMLElement) $ getHead doc
189193 attachWidget headElement webView h
190− Just body <- documentGetBody doc
194+ Just body <- getBody doc
191195 attachWidget body webView b
192196
193197mainWidgetWithCss :: ByteString -> Widget Spider (Gui Spider (WithWebView SpiderHost) (HostFrame Spider)) () -> IO ()
194198mainWidgetWithCss css w = runWebGUI $ \webView -> do
195199 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
200+ Just headElement <- liftM (fmap castToHTMLElement) $ getHead doc
201+ setInnerHTML headElement . Just $ "<style>" <> T.unpack (decodeUtf8 css) <> "</style>" --TODO: Fix this
202+ Just body <- getBody doc
199203 attachWidget body webView w
200204
201205newtype WithWebView m a = WithWebView { unWithWebView :: ReaderT WebView m a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadException, MonadAsyncException)
@@ -245,20 +249,20 @@ runWithWebView = runReaderT . unWithWebView
245249
246250attachWidget :: (IsHTMLElement e) => e -> WebView -> Widget Spider (Gui Spider (WithWebView SpiderHost) (HostFrame Spider)) a -> IO a
247251attachWidget rootElement wv w = runSpiderHost $ flip runWithWebView wv $ do --TODO: It seems to re-run this handler if the URL changes, even if it's only the fragment
248− Just doc <- liftM (fmap castToHTMLDocument) $ liftIO $ nodeGetOwnerDocument rootElement
252+ Just doc <- liftM (fmap castToHTMLDocument) $ getOwnerDocument rootElement
249253 frames <- liftIO newChan
250254 rec let guiEnv = GuiEnv doc (writeChan frames . runSpiderHost . flip runWithWebView wv) runWithActions wv :: GuiEnv Spider (WithWebView SpiderHost)
251255 runWithActions dm = do
252256 voidActionNeeded <- fireEventsAndRead dm $ do
253257 sequence =<< readEvent voidActionHandle
254258 runHostFrame $ runGui (sequence_ voidActionNeeded) guiEnv
255− Just df <- liftIO $ documentCreateDocumentFragment doc
259+ Just df <- createDocumentFragment doc
256260 (result, voidAction) <- runHostFrame $ flip runGui guiEnv $ do
257261 (r, postBuild, va) <- runWidget df w
258262 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
259263 return (r, va)
260− liftIO $ htmlElementSetInnerHTML rootElement ""
261− _ <- liftIO $ nodeAppendChild rootElement $ Just df
264+ setInnerHTML rootElement $ Just ""
265+ _ <- appendChild rootElement $ Just df
262266 voidActionHandle <- subscribeEvent voidAction --TODO: Should be unnecessary
263267 --postGUISync seems to leak memory on GHC (unknown on GHCJS)
264268 _ <- liftIO $ forkIO $ forever $ postGUISync =<< readChan frames -- postGUISync is necessary to prevent segfaults in GTK, which is not thread-safe
src/Reflex/Dom/Location.hsnew file+3
@@ -0,0 +1,3 @@
1+module Reflex.Dom.Location (getLocationHost, getLocationProtocol) where
2+
3+import Reflex.Dom.Internal.Foreign
src/Reflex/Dom/Time.hs+1−1
@@ -63,7 +63,7 @@ delay dt e = performEventAsync $ ffor e $ \a cb -> liftIO $ void $ forkIO $ do
6363 threadDelay $ ceiling $ dt * 1000000
6464 cb a
6565
66−-- | Block occurrences of an Event until th given number of seconds elapses without
66+-- | Block occurrences of an Event until the given number of seconds elapses without
6767-- the Event firing, at which point the last occurrence of the Event will fire.
6868debounce :: MonadWidget t m => NominalDiffTime -> Event t a -> m (Event t a)
6969debounce dt e = do
src/Reflex/Dom/WebSocket.hsnew file+68
@@ -0,0 +1,68 @@
1+{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI, CPP, TemplateHaskell, NoMonomorphismRestriction, EmptyDataDecls, RankNTypes, GADTs, RecursiveDo, ScopedTypeVariables, FlexibleInstances, MultiParamTypeClasses, TypeFamilies, FlexibleContexts, DeriveDataTypeable, GeneralizedNewtypeDeriving, StandaloneDeriving, ConstraintKinds, UndecidableInstances, PolyKinds, AllowAmbiguousTypes #-}
2+
3+module Reflex.Dom.WebSocket where
4+
5+import Prelude hiding (div, span, mapM, mapM_, concat, concatMap, all, sequence)
6+
7+import Reflex
8+import Reflex.Host.Class
9+import Reflex.Dom.Class
10+import Reflex.Dom.WebSocket.Foreign
11+
12+import Control.Concurrent
13+import Control.Lens
14+import Control.Monad hiding (forM, forM_, mapM, mapM_, sequence)
15+import Control.Monad.IO.Class
16+import Control.Monad.Ref
17+import Control.Monad.State
18+import Data.ByteString (ByteString)
19+import Data.Default
20+import Data.Dependent.Map (DSum (..))
21+import Data.IORef
22+
23+data WebSocketConfig t
24+ = WebSocketConfig { _webSocketConfig_send :: Event t [ByteString]
25+ }
26+
27+instance Reflex t => Default (WebSocketConfig t) where
28+ def = WebSocketConfig never
29+
30+data WebSocket t
31+ = WebSocket { _webSocket_recv :: Event t ByteString
32+ , _webSocket_open :: Event t ()
33+ }
34+
35+webSocket :: forall t m. (HasWebView m, MonadWidget t m) => String -> WebSocketConfig t -> m (WebSocket t)
36+webSocket url config = do
37+ wv <- askWebView
38+ postGui <- askPostGui
39+ runWithActions <- askRunWithActions
40+ (eRecv, eRecvTriggerRef) <- newEventWithTriggerRef
41+ currentSocketRef <- liftIO $ newIORef Nothing
42+ --TODO: Disconnect if value no longer needed
43+ (eOpen, eOpenTriggerRef) <- newEventWithTriggerRef
44+ let onMessage :: ByteString -> IO ()
45+ onMessage m = postGui $ do
46+ mt <- readRef eRecvTriggerRef
47+ forM_ mt $ \t -> runWithActions [t :=> Identity m]
48+ onOpen = postGui $ do
49+ mt <- readRef eOpenTriggerRef
50+ forM_ mt $ \t -> runWithActions [t :=> Identity ()]
51+ start = do
52+ ws <- liftIO $ newWebSocket wv url onMessage onOpen $ do
53+ void $ forkIO $ do --TODO: Is the fork necessary, or do event handlers run in their own threads automatically?
54+ liftIO $ writeIORef currentSocketRef Nothing
55+ liftIO $ threadDelay 1000000
56+ start
57+ liftIO $ writeIORef currentSocketRef $ Just ws
58+ return ()
59+ schedulePostBuild $ liftIO start
60+ performEvent_ $ ffor (_webSocketConfig_send config) $ \payloads -> forM_ payloads $ \payload -> do
61+ mws <- liftIO $ readIORef currentSocketRef
62+ case mws of
63+ Nothing -> return () -- Discard --TODO: should we do something better here? probably buffer it, since we handle reconnection logic; how do we verify that the server has received things?
64+ Just ws -> do
65+ liftIO $ webSocketSend ws payload
66+ return $ WebSocket eRecv eOpen
67+
68+makeLensesWith (lensRules & simpleLenses .~ True) ''WebSocketConfig
src/Reflex/Dom/Widget/Basic.hs+168−157
@@ -21,12 +21,12 @@ import Control.Monad.Reader hiding (mapM, mapM_, forM, forM_, sequence, sequence
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
@@ -130,7 +130,7 @@ display a = dynText =<< mapDyn show a
130130--TODO: Should this be renamed to 'widgetView' for consistency with 'widgetHold'?
131131-- | Given a Dynamic of widget-creating actions, create a widget that is recreated whenever the Dynamic updates.
132132-- The returned Event of widget results occurs when the Dynamic does.
133−-- Note: Often, the type 'a' is an Event, in which case the return value is an Event-of-Events that would typically be flattened.
133+-- Note: Often, the type 'a' is an Event, in which case the return value is an Event-of-Events that would typically be flattened (via 'switchPromptly').
134134dyn :: MonadWidget t m => Dynamic t (m a) -> m (Event t a)
135135dyn child = do
136136 postBuild <- getPostBuild
@@ -158,17 +158,15 @@ widgetHoldInternal child0 newChild = do
158158 tellWidgetOutput childOutput
159159 doc <- askDocument
160160 runWidget <- getRunWidget
161− let build c = do
162− Just df <- liftIO $ documentCreateDocumentFragment doc
163− (result, postBuild, voidActions) <- runWidget df c
164− runFrameWithTriggerRef newChildBuiltTriggerRef (result, voidActions)
165− postBuild
166− mp' <- liftIO $ nodeGetParentNode endPlaceholder
167− forM_ mp' $ \p' -> liftIO $ nodeInsertBefore p' (Just df) (Just endPlaceholder)
168− return ()
169161 addVoidAction $ ffor newChild $ \c -> do
162+ Just df <- createDocumentFragment doc
163+ (result, postBuild, voidActions) <- runWidget df c
164+ runFrameWithTriggerRef newChildBuiltTriggerRef (result, voidActions)
165+ postBuild
170166 liftIO $ deleteBetweenExclusive startPlaceholder endPlaceholder
171− build c
167+ mp' <- getParentNode endPlaceholder
168+ forM_ mp' $ \p' -> insertBefore p' (Just df) (Just endPlaceholder)
169+ return ()
172170 return (result0, fmap fst newChildBuilt)
173171
174172diffMapNoEq :: (Ord k) => Map k v -> Map k v -> Map k (Maybe v)
@@ -209,7 +207,7 @@ listWithKeyShallowDiff initialVals valsChanged mkChild = do
209207 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
210208 Just _ -> Nothing -- We don't want to let spurious re-creations of items through
211209 listHoldWithKey initialVals (attachWith (flip (Map.differenceWith relevantDiff)) (current sentVals) valsChanged) $ \k v ->
212− mkChild k v $ select childValChangedSelector $ Const2 k
210+ mkChild k v $ Reflex.select childValChangedSelector $ Const2 k
213211
214212-- | 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.
215213listHoldWithKey :: (Ord k, MonadWidget t m) => Map k v -> Event t (Map k (Maybe v)) -> (k -> v -> m a) -> m (Dynamic t (Map k a))
@@ -224,13 +222,13 @@ listHoldWithKey initialVals valsChanged mkChild = do
224222 result <- mkChild k v
225223 childEnd <- text' ""
226224 return (result, (childStart, childEnd))
227− Just dfOrig <- liftIO $ documentCreateDocumentFragment doc
225+ Just dfOrig <- createDocumentFragment doc
228226 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
229227 stateRef <- liftIO $ newIORef initialState
230228 children <- holdDyn initialState newChildren
231229 tellWidgetOutput =<< mapDyn (fmap snd) children
232− mpOrig <- liftIO $ nodeGetParentNode endPlaceholder
233− forM_ mpOrig $ \pOrig -> liftIO $ nodeInsertBefore pOrig (Just dfOrig) (Just endPlaceholder)
230+ mpOrig <- liftIO $ getParentNode endPlaceholder
231+ forM_ mpOrig $ \pOrig -> liftIO $ insertBefore pOrig (Just dfOrig) (Just endPlaceholder)
234232 addVoidAction $ flip fmap valsChanged $ \newVals -> do
235233 curState <- liftIO $ readIORef stateRef
236234 --TODO: Should we remove the parent from the DOM first to avoid reflows?
@@ -240,24 +238,24 @@ listHoldWithKey initialVals valsChanged mkChild = do
240238 return Nothing
241239 These ((_, (start, end)), _) (Just v) -> do -- Replacing existing child
242240 liftIO $ deleteBetweenExclusive start end
243− Just df <- liftIO $ documentCreateDocumentFragment doc
241+ Just df <- createDocumentFragment doc
244242 (childResult, childPostBuild, childVoidAction) <- lift $ buildChild df k v
245243 let s = (childResult, childVoidAction)
246244 modify (>>childPostBuild)
247− mp <- liftIO $ nodeGetParentNode end
248− forM_ mp $ \p -> liftIO $ nodeInsertBefore p (Just df) (Just end)
245+ mp <- getParentNode end
246+ forM_ mp $ \p -> insertBefore p (Just df) (Just end)
249247 return $ Just s
250248 That Nothing -> return Nothing -- Deleting non-existent child
251249 That (Just v) -> do -- Creating new child
252− Just df <- liftIO $ documentCreateDocumentFragment doc
250+ Just df <- createDocumentFragment doc
253251 (childResult, childPostBuild, childVoidAction) <- lift $ buildChild df k v
254252 let s = (childResult, childVoidAction)
255253 modify (>>childPostBuild)
256254 let placeholder = case Map.lookupGT k curState of
257255 Nothing -> endPlaceholder
258256 Just (_, ((_, (start, _)), _)) -> start
259− mp <- liftIO $ nodeGetParentNode placeholder
260− forM_ mp $ \p -> liftIO $ nodeInsertBefore p (Just df) (Just placeholder)
257+ mp <- getParentNode placeholder
258+ forM_ mp $ \p -> insertBefore p (Just df) (Just placeholder)
261259 return $ Just s
262260 This state -> do -- No change
263261 return $ Just state
@@ -303,47 +301,56 @@ selectViewListWithKey_ selection vals mkChild = liftM (fmap fst) $ selectViewLis
303301-- | s and e must both be children of the same node and s must precede e
304302deleteBetweenExclusive :: (IsNode start, IsNode end) => start -> end -> IO ()
305303deleteBetweenExclusive s e = do
306− mCurrentParent <- nodeGetParentNode e -- May be different than it was at initial construction, e.g., because the parent may have dumped us in from a DocumentFragment
304+ mCurrentParent <- getParentNode e -- May be different than it was at initial construction, e.g., because the parent may have dumped us in from a DocumentFragment
307305 case mCurrentParent of
308306 Nothing -> return () --TODO: Is this the right behavior?
309307 Just currentParent -> do
310308 let go = do
311− Just x <- nodeGetPreviousSibling e -- This can't be Nothing because we should hit 's' first
309+ Just x <- getPreviousSibling e -- This can't be Nothing because we should hit 's' first
312310 when (toNode s /= toNode x) $ do
313− _ <- nodeRemoveChild currentParent $ Just x
311+ _ <- removeChild currentParent $ Just x
314312 go
315313 go
316314
317315-- | s and e must both be children of the same node and s must precede e
318316deleteBetweenInclusive :: (IsNode start, IsNode end) => start -> end -> IO ()
319317deleteBetweenInclusive s e = do
320− mCurrentParent <- nodeGetParentNode e -- May be different than it was at initial construction, e.g., because the parent may have dumped us in from a DocumentFragment
318+ mCurrentParent <- getParentNode e -- May be different than it was at initial construction, e.g., because the parent may have dumped us in from a DocumentFragment
321319 case mCurrentParent of
322320 Nothing -> return () --TODO: Is this the right behavior?
323321 Just currentParent -> do
324322 let go = do
325− Just x <- nodeGetPreviousSibling e -- This can't be Nothing because we should hit 's' first
326− _ <- nodeRemoveChild currentParent $ Just x
323+ Just x <- getPreviousSibling e -- This can't be Nothing because we should hit 's' first
324+ _ <- removeChild currentParent $ Just x
327325 when (toNode s /= toNode x) go
328326 go
329− _ <- nodeRemoveChild currentParent $ Just e
327+ _ <- removeChild currentParent $ Just e
330328 return ()
331329
330+nodeClear :: IsNode self => self -> IO ()
331+nodeClear n = do
332+ mfc <- getFirstChild n
333+ case mfc of
334+ Nothing -> return ()
335+ Just fc -> do
336+ _ <- removeChild n $ Just fc
337+ nodeClear n
338+
332339--------------------------------------------------------------------------------
333340-- Adapters
334341--------------------------------------------------------------------------------
335342
336−wrapDomEvent :: (Functor (Event t), MonadIO m, MonadSample t m, MonadReflexCreateTrigger t m, Reflex t, HasPostGui t h m) => e -> (e -> EventM event e () -> IO (IO ())) -> EventM event e a -> m (Event t a)
343+wrapDomEvent :: (Functor (Event t), MonadIO m, MonadSample t m, MonadReflexCreateTrigger t m, Reflex t, HasPostGui t h m) => e -> (e -> EventM e event () -> IO (IO ())) -> EventM e event a -> m (Event t a)
337344wrapDomEvent element elementOnevent getValue = wrapDomEventMaybe element elementOnevent $ liftM Just getValue
338345
339−wrapDomEventMaybe :: (Functor (Event t), MonadIO m, MonadSample t m, MonadReflexCreateTrigger t m, Reflex t, HasPostGui t h m) => e -> (e -> EventM event e () -> IO (IO ())) -> EventM event e (Maybe a) -> m (Event t a)
346+wrapDomEventMaybe :: (Functor (Event t), MonadIO m, MonadSample t m, MonadReflexCreateTrigger t m, Reflex t, HasPostGui t h m) => e -> (e -> EventM e event () -> IO (IO ())) -> EventM e event (Maybe a) -> m (Event t a)
340347wrapDomEventMaybe element elementOnevent getValue = do
341348 postGui <- askPostGui
342349 runWithActions <- askRunWithActions
343350 e <- newEventWithTrigger $ \et -> do
344351 unsubscribe <- {-# SCC "a" #-} liftIO $ {-# SCC "b" #-} elementOnevent element $ {-# SCC "c" #-} do
345352 mv <- {-# SCC "d" #-} getValue
346− forM_ mv $ \v -> liftIO $ postGui $ runWithActions [et :=> v]
353+ forM_ mv $ \v -> liftIO $ postGui $ runWithActions [et :=> Identity v]
347354 return $ liftIO $ do
348355 {-# SCC "e" #-} unsubscribe
349356 return $! {-# SCC "f" #-} e
@@ -377,11 +384,11 @@ data EventTag
377384 | MouseoutTag
378385 | MouseoverTag
379386 | MouseupTag
380−-- | MousewheelTag -- webkitgtk only provides elementOnmousewheel (not elementOnwheel), but firefox does not support the mousewheel event; we should provide wheel (the equivalent, standard event), but we will need to make sure webkitgtk supports it first
387+ | MousewheelTag
381388 | ScrollTag
382389 | SelectTag
383390 | SubmitTag
384−-- | WheelTag -- See MousewheelTag
391+ | WheelTag
385392 | BeforecutTag
386393 | CutTag
387394 | BeforecopyTag
@@ -425,11 +432,11 @@ data EventName :: EventTag -> * where
425432 Mouseout :: EventName 'MouseoutTag
426433 Mouseover :: EventName 'MouseoverTag
427434 Mouseup :: EventName 'MouseupTag
428− --Mousewheel :: EventName 'MousewheelTag
435+ Mousewheel :: EventName 'MousewheelTag
429436 Scroll :: EventName 'ScrollTag
430437 Select :: EventName 'SelectTag
431438 Submit :: EventName 'SubmitTag
432− --Wheel :: EventName 'WheelTag
439+ Wheel :: EventName 'WheelTag
433440 Beforecut :: EventName 'BeforecutTag
434441 Cut :: EventName 'CutTag
435442 Beforecopy :: EventName 'BeforecopyTag
@@ -446,8 +453,8 @@ data EventName :: EventTag -> * where
446453
447454type family EventType en where
448455 EventType 'AbortTag = UIEvent
449− EventType 'BlurTag = UIEvent
450− EventType 'ChangeTag = UIEvent
456+ EventType 'BlurTag = FocusEvent
457+ EventType 'ChangeTag = DOM.Event
451458 EventType 'ClickTag = MouseEvent
452459 EventType 'ContextmenuTag = MouseEvent
453460 EventType 'DblclickTag = MouseEvent
@@ -459,87 +466,87 @@ type family EventType en where
459466 EventType 'DragstartTag = MouseEvent
460467 EventType 'DropTag = MouseEvent
461468 EventType 'ErrorTag = UIEvent
462− EventType 'FocusTag = UIEvent
463− EventType 'InputTag = UIEvent
464− EventType 'InvalidTag = UIEvent
465− EventType 'KeydownTag = UIEvent
466− EventType 'KeypressTag = UIEvent
467− EventType 'KeyupTag = UIEvent
469+ EventType 'FocusTag = FocusEvent
470+ EventType 'InputTag = DOM.Event
471+ EventType 'InvalidTag = DOM.Event
472+ EventType 'KeydownTag = KeyboardEvent
473+ EventType 'KeypressTag = KeyboardEvent
474+ EventType 'KeyupTag = KeyboardEvent
468475 EventType 'LoadTag = UIEvent
469476 EventType 'MousedownTag = MouseEvent
470− EventType 'MouseenterTag = UIEvent
471− EventType 'MouseleaveTag = UIEvent
477+ EventType 'MouseenterTag = MouseEvent
478+ EventType 'MouseleaveTag = MouseEvent
472479 EventType 'MousemoveTag = MouseEvent
473480 EventType 'MouseoutTag = MouseEvent
474481 EventType 'MouseoverTag = MouseEvent
475482 EventType 'MouseupTag = MouseEvent
476− --EventType 'MousewheelTag = MouseEvent
483+ EventType 'MousewheelTag = MouseEvent
477484 EventType 'ScrollTag = UIEvent
478485 EventType 'SelectTag = UIEvent
479− EventType 'SubmitTag = UIEvent
480− --EventType 'WheelTag = UIEvent
481− EventType 'BeforecutTag = UIEvent
482− EventType 'CutTag = UIEvent
483− EventType 'BeforecopyTag = UIEvent
484− EventType 'CopyTag = UIEvent
485− EventType 'BeforepasteTag = UIEvent
486− EventType 'PasteTag = UIEvent
487− EventType 'ResetTag = UIEvent
488− EventType 'SearchTag = UIEvent
489− EventType 'SelectstartTag = UIEvent
490− EventType 'TouchstartTag = UIEvent
491− EventType 'TouchmoveTag = UIEvent
492− EventType 'TouchendTag = UIEvent
493− EventType 'TouchcancelTag = UIEvent
494−
495−onEventName :: IsElement e => EventName en -> e -> EventM (EventType en) e () -> IO (IO ())
496−onEventName en = case en of
497− Abort -> elementOnabort
498− Blur -> elementOnblur
499− Change -> elementOnchange
500− Click -> elementOnclick
501− Contextmenu -> elementOncontextmenu
502− Dblclick -> elementOndblclick
503− Drag -> elementOndrag
504− Dragend -> elementOndragend
505− Dragenter -> elementOndragenter
506− Dragleave -> elementOndragleave
507− Dragover -> elementOndragover
508− Dragstart -> elementOndragstart
509− Drop -> elementOndrop
510− Error -> elementOnerror
511− Focus -> elementOnfocus
512− Input -> elementOninput
513− Invalid -> elementOninvalid
514− Keydown -> elementOnkeydown
515− Keypress -> elementOnkeypress
516− Keyup -> elementOnkeyup
517− Load -> elementOnload
518− Mousedown -> elementOnmousedown
519− Mouseenter -> elementOnmouseenter
520− Mouseleave -> elementOnmouseleave
521− Mousemove -> elementOnmousemove
522− Mouseout -> elementOnmouseout
523− Mouseover -> elementOnmouseover
524− Mouseup -> elementOnmouseup
525− --Mousewheel -> elementOnmousewheel
526− Scroll -> elementOnscroll
527− Select -> elementOnselect
528− Submit -> elementOnsubmit
529− --Wheel -> elementOnwheel
530− Beforecut -> elementOnbeforecut
531− Cut -> elementOncut
532− Beforecopy -> elementOnbeforecopy
533− Copy -> elementOncopy
534− Beforepaste -> elementOnbeforepaste
535− Paste -> elementOnpaste
536− Reset -> elementOnreset
537− Search -> elementOnsearch
538− Selectstart -> elementOnselectstart
539− Touchstart -> elementOntouchstart
540− Touchmove -> elementOntouchmove
541− Touchend -> elementOntouchend
542− Touchcancel -> elementOntouchcancel
486+ EventType 'SubmitTag = DOM.Event
487+ EventType 'WheelTag = WheelEvent
488+ EventType 'BeforecutTag = DOM.Event
489+ EventType 'CutTag = DOM.Event
490+ EventType 'BeforecopyTag = DOM.Event
491+ EventType 'CopyTag = DOM.Event
492+ EventType 'BeforepasteTag = DOM.Event
493+ EventType 'PasteTag = DOM.Event
494+ EventType 'ResetTag = DOM.Event
495+ EventType 'SearchTag = DOM.Event
496+ EventType 'SelectstartTag = DOM.Event
497+ EventType 'TouchstartTag = TouchEvent
498+ EventType 'TouchmoveTag = TouchEvent
499+ EventType 'TouchendTag = TouchEvent
500+ EventType 'TouchcancelTag = TouchEvent
501+
502+onEventName :: IsElement e => EventName en -> e -> EventM e (EventType en) () -> IO (IO ())
503+onEventName en e = case en of
504+ Abort -> on e E.abort
505+ Blur -> on e E.blurEvent
506+ Change -> on e E.change
507+ Click -> on e E.click
508+ Contextmenu -> on e E.contextMenu
509+ Dblclick -> on e E.dblClick
510+ Drag -> on e E.drag
511+ Dragend -> on e E.dragEnd
512+ Dragenter -> on e E.dragEnter
513+ Dragleave -> on e E.dragLeave
514+ Dragover -> on e E.dragOver
515+ Dragstart -> on e E.dragStart
516+ Drop -> on e E.drop
517+ Error -> on e E.error
518+ Focus -> on e E.focusEvent
519+ Input -> on e E.input
520+ Invalid -> on e E.invalid
521+ Keydown -> on e E.keyDown
522+ Keypress -> on e E.keyPress
523+ Keyup -> on e E.keyUp
524+ Load -> on e E.load
525+ Mousedown -> on e E.mouseDown
526+ Mouseenter -> on e E.mouseEnter
527+ Mouseleave -> on e E.mouseLeave
528+ Mousemove -> on e E.mouseMove
529+ Mouseout -> on e E.mouseOut
530+ Mouseover -> on e E.mouseOver
531+ Mouseup -> on e E.mouseUp
532+ Mousewheel -> on e E.mouseWheel
533+ Scroll -> on e E.scroll
534+ Select -> on e E.select
535+ Submit -> on e E.submit
536+ Wheel -> on e E.wheel
537+ Beforecut -> on e E.beforeCut
538+ Cut -> on e E.cut
539+ Beforecopy -> on e E.beforeCopy
540+ Copy -> on e E.copy
541+ Beforepaste -> on e E.beforePaste
542+ Paste -> on e E.paste
543+ Reset -> on e E.reset
544+ Search -> on e E.search
545+ Selectstart -> on e E.selectStart
546+ Touchstart -> on e E.touchStart
547+ Touchmove -> on e E.touchMove
548+ Touchend -> on e E.touchEnd
549+ Touchcancel -> on e E.touchCancel
543550
544551newtype EventResult en = EventResult { unEventResult :: EventResultType en }
545552
@@ -588,42 +595,43 @@ type family EventResultType (en :: EventTag) :: * where
588595 EventResultType 'TouchmoveTag = ()
589596 EventResultType 'TouchendTag = ()
590597 EventResultType 'TouchcancelTag = ()
598+ EventResultType 'MousewheelTag = ()
599+ EventResultType 'WheelTag = ()
591600
592−wrapDomEventsMaybe :: (Functor (Event t), IsElement e, MonadIO m, MonadSample t m, MonadReflexCreateTrigger t m, Reflex t, HasPostGui t h m) => e -> (forall en. EventName en -> EventM (EventType en) e (Maybe (f en))) -> m (EventSelector t (WrapArg f EventName))
601+wrapDomEventsMaybe :: (Functor (Event t), IsElement e, MonadIO m, MonadSample t m, MonadReflexCreateTrigger t m, Reflex t, HasPostGui t h m) => e -> (forall en. EventName en -> EventM e (EventType en) (Maybe (f en))) -> m (EventSelector t (WrapArg f EventName))
593602wrapDomEventsMaybe element handlers = do
594603 postGui <- askPostGui
595604 runWithActions <- askRunWithActions
596605 e <- newFanEventWithTrigger $ \(WrapArg en) et -> do
597− unsubscribe <- liftIO $ (onEventName en) element $ do
606+ unsubscribe <- onEventName en element $ do
598607 mv <- handlers en
599− forM_ mv $ \v -> liftIO $ postGui $ runWithActions [et :=> v]
608+ forM_ mv $ \v -> liftIO $ postGui $ runWithActions [et :=> Identity v]
600609 return $ liftIO $ do
601610 unsubscribe
602611 return $! e
603612
604−getKeyEvent :: EventM UIEvent e Int
613+getKeyEvent :: EventM e KeyboardEvent Int
605614getKeyEvent = do
606615 e <- event
607− liftIO $ do
608− which <- uiEventGetWhich e
609− if which /= 0 then return which else do
610− charCode <- uiEventGetCharCode e
611− if charCode /= 0 then return charCode else
612− uiEventGetKeyCode e
613−
614−getMouseEventCoords :: EventM MouseEvent e (Int, Int)
616+ which <- getWhich e
617+ if which /= 0 then return which else do
618+ charCode <- getCharCode e
619+ if charCode /= 0 then return charCode else
620+ getKeyCode e
621+
622+getMouseEventCoords :: EventM e MouseEvent (Int, Int)
615623getMouseEventCoords = do
616624 e <- event
617− liftIO $ bisequence (mouseEventGetClientX e, mouseEventGetClientY e)
625+ bisequence (getX e, getY e)
618626
619−defaultDomEventHandler :: IsElement e => e -> EventName en -> EventM (EventType en) e (Maybe (EventResult en))
627+defaultDomEventHandler :: IsElement e => e -> EventName en -> EventM e (EventType en) (Maybe (EventResult en))
620628defaultDomEventHandler e evt = liftM (Just . EventResult) $ case evt of
621629 Click -> return ()
622630 Dblclick -> return ()
623631 Keypress -> getKeyEvent
632+ Scroll -> getScrollTop e
624633 Keydown -> getKeyEvent
625634 Keyup -> getKeyEvent
626− Scroll -> liftIO $ elementGetScrollTop e
627635 Mousemove -> getMouseEventCoords
628636 Mouseup -> getMouseEventCoords
629637 Mousedown -> getMouseEventCoords
@@ -662,8 +670,10 @@ defaultDomEventHandler e evt = liftM (Just . EventResult) $ case evt of
662670 Touchmove -> return ()
663671 Touchend -> return ()
664672 Touchcancel -> return ()
673+ Mousewheel -> return ()
674+ Wheel -> return ()
665675
666−wrapElement :: forall t h m. (Functor (Event t), MonadIO m, MonadSample t m, MonadReflexCreateTrigger t m, Reflex t, HasPostGui t h m) => (forall en. Element -> EventName en -> EventM (EventType en) Element (Maybe (EventResult en))) -> Element -> m (El t)
676+wrapElement :: forall t h m. (Functor (Event t), MonadIO m, MonadSample t m, MonadReflexCreateTrigger t m, Reflex t, HasPostGui t h m) => (forall en. Element -> EventName en -> EventM Element (EventType en) (Maybe (EventResult en))) -> Element -> m (El t)
667677wrapElement eh e = do
668678 es <- wrapDomEventsMaybe e $ eh e
669679 return $ El e es
@@ -748,17 +758,15 @@ simpleList xs mkChild = mapDyn (map snd . Map.toList) =<< flip list mkChild =<<
748758elDynHtml' :: MonadWidget t m => String -> Dynamic t String -> m (El t)
749759elDynHtml' elementTag html = do
750760 e <- buildEmptyElement elementTag (Map.empty :: Map String String)
751− let h = castToHTMLElement e
752− schedulePostBuild $ liftIO . htmlElementSetInnerHTML h =<< sample (current html)
753− addVoidAction $ fmap (liftIO . htmlElementSetInnerHTML h) $ updated html
761+ schedulePostBuild $ setInnerHTML e . Just =<< sample (current html)
762+ addVoidAction $ fmap (setInnerHTML e . Just) $ updated html
754763 wrapElement defaultDomEventHandler e
755764
756765elDynHtmlAttr' :: MonadWidget t m => String -> Map String String -> Dynamic t String -> m (El t)
757766elDynHtmlAttr' elementTag attrs html = do
758767 e <- buildEmptyElement elementTag attrs
759− let h = castToHTMLElement e
760− schedulePostBuild $ liftIO . htmlElementSetInnerHTML h =<< sample (current html)
761− addVoidAction $ fmap (liftIO . htmlElementSetInnerHTML h) $ updated html
768+ schedulePostBuild $ setInnerHTML e . Just =<< sample (current html)
769+ addVoidAction $ fmap (setInnerHTML e . Just) $ updated html
762770 wrapElement defaultDomEventHandler e
763771
764772data Link t
@@ -783,7 +791,7 @@ class HasDomEvent t a where
783791 domEvent :: EventName en -> a -> Event t (EventResultType en)
784792
785793instance Reflex t => HasDomEvent t (El t) where
786− domEvent en e = fmap unEventResult $ select (_el_events e) (WrapArg en)
794+ domEvent en e = fmap unEventResult $ Reflex.select (_el_events e) (WrapArg en)
787795
788796linkClass :: MonadWidget t m => String -> String -> m (Link t)
789797linkClass s c = do
@@ -795,7 +803,7 @@ link s = linkClass s ""
795803
796804button :: MonadWidget t m => String -> m (Event t ())
797805button s = do
798− (e, _) <- el' "button" $ text s
806+ (e, _) <- elAttr' "button" (Map.singleton "type" "button") $ text s
799807 return $ domEvent Click e
800808
801809newtype Workflow t m a = Workflow { unWorkflow :: m (a, Event t (Workflow t m a)) }
@@ -811,6 +819,9 @@ workflowView w0 = do
811819 eReplace <- liftM switch $ hold never $ fmap snd eResult
812820 return $ fmap fst eResult
813821
822+mapWorkflow :: (MonadWidget t m) => (a -> b) -> Workflow t m a -> Workflow t m b
823+mapWorkflow f (Workflow x) = Workflow (fmap (\(v,e) -> (f v, fmap (mapWorkflow f) e)) x)
824+
814825divClass :: forall t m a. MonadWidget t m => String -> m a -> m a
815826divClass = elClass "div"
816827
@@ -858,7 +869,7 @@ tabDisplay ulClass activeClass tabItems = do
858869 _ <- listWithKey dTabs (\k dTab -> do
859870 dAttrs <- mapDyn (\sel -> do
860871 let t1 = listToMaybe $ Map.keys tabItems
861− if sel == Just k || (sel == Nothing && t1 == Just k) then Map.empty else Map.singleton "style" "display:none;") dCurrentTab
872+ if sel == Just k || (sel == Nothing && t1 == Just k) then Map.empty else Map.singleton "style" "display:none;") dCurrentTab
862873 elDynAttr "div" dAttrs $ dyn =<< mapDyn snd dTab)
863874 return ()
864875 where
@@ -873,7 +884,7 @@ tabDisplay ulClass activeClass tabItems = do
873884unsafePlaceElement :: MonadWidget t m => Element -> m (El t)
874885unsafePlaceElement e = do
875886 p <- askParent
876− _ <- liftIO $ nodeAppendChild p $ Just e
887+ _ <- appendChild p $ Just e
877888 wrapElement defaultDomEventHandler e
878889
879890deriveGEq ''EventName
src/Reflex/Dom/Widget/Input.hs+56−52
@@ -8,22 +8,24 @@ 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
19−import Data.Map as Map
20−import Control.Lens
19+import qualified Data.Map as Map
20+import Control.Lens hiding (ix)
2121import Control.Monad hiding (forM_)
2222import Control.Monad.IO.Class
23+import qualified Data.Bimap as B
2324import Data.Default
24−import Data.Maybe
25−import Safe
2625import Data.Dependent.Sum (DSum (..))
26+import Data.Map (Map)
27+import Data.Maybe
28+import Text.Read
2729
2830data TextInput t
2931 = TextInput { _textInput_value :: Dynamic t String
@@ -53,21 +55,21 @@ instance Reflex t => Default (TextInputConfig t) where
5355textInput :: MonadWidget t m => TextInputConfig t -> m (TextInput t)
5456textInput (TextInputConfig inputType initial eSetValue dAttrs) = do
5557 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
58+ Input.setValue e $ Just initial
59+ performEvent_ $ fmap (Input.setValue e . Just) eSetValue
60+ eChange <- wrapDomEvent e (`on` input) $ fromMaybe "" <$> Input.getValue e
5961 postGui <- askPostGui
6062 runWithActions <- askRunWithActions
6163 eChangeFocus <- newEventWithTrigger $ \eChangeFocusTrigger -> do
62− unsubscribeOnblur <- liftIO $ elementOnblur e $ liftIO $ do
63− postGui $ runWithActions [eChangeFocusTrigger :=> False]
64− unsubscribeOnfocus <- liftIO $ elementOnfocus e $ liftIO $ do
65− postGui $ runWithActions [eChangeFocusTrigger :=> True]
64+ unsubscribeOnblur <- on e blurEvent $ liftIO $ do
65+ postGui $ runWithActions [eChangeFocusTrigger :=> Identity False]
66+ unsubscribeOnfocus <- on e focusEvent $ liftIO $ do
67+ postGui $ runWithActions [eChangeFocusTrigger :=> Identity True]
6668 return $ liftIO $ unsubscribeOnblur >> unsubscribeOnfocus
6769 dFocus <- holdDyn False eChangeFocus
68− eKeypress <- wrapDomEvent e elementOnkeypress getKeyEvent
69− eKeydown <- wrapDomEvent e elementOnkeydown getKeyEvent
70− eKeyup <- wrapDomEvent e elementOnkeyup getKeyEvent
70+ eKeypress <- wrapDomEvent e (`on` keyPress) getKeyEvent
71+ eKeydown <- wrapDomEvent e (`on` keyDown) getKeyEvent
72+ eKeyup <- wrapDomEvent e (`on` keyUp) getKeyEvent
7173 dValue <- holdDyn initial $ leftmost [eSetValue, eChange]
7274 return $ TextInput dValue eChange eKeypress eKeydown eKeyup dFocus e
7375
@@ -97,20 +99,20 @@ data TextArea t
9799textArea :: MonadWidget t m => TextAreaConfig t -> m (TextArea t)
98100textArea (TextAreaConfig initial eSet attrs) = do
99101 e <- liftM castToHTMLTextAreaElement $ buildEmptyElement "textarea" attrs
100− liftIO $ htmlTextAreaElementSetValue e initial
102+ TextArea.setValue e $ Just initial
101103 postGui <- askPostGui
102104 runWithActions <- askRunWithActions
103105 eChangeFocus <- newEventWithTrigger $ \eChangeFocusTrigger -> do
104− unsubscribeOnblur <- liftIO $ elementOnblur e $ liftIO $ do
105− postGui $ runWithActions [eChangeFocusTrigger :=> False]
106− unsubscribeOnfocus <- liftIO $ elementOnfocus e $ liftIO $ do
107− postGui $ runWithActions [eChangeFocusTrigger :=> True]
106+ unsubscribeOnblur <- on e blurEvent $ liftIO $ do
107+ postGui $ runWithActions [eChangeFocusTrigger :=> Identity False]
108+ unsubscribeOnfocus <- on e focusEvent $ liftIO $ do
109+ postGui $ runWithActions [eChangeFocusTrigger :=> Identity True]
108110 return $ liftIO $ unsubscribeOnblur >> unsubscribeOnfocus
109− performEvent_ $ fmap (liftIO . htmlTextAreaElementSetValue e) eSet
111+ performEvent_ $ fmap (TextArea.setValue e . Just) eSet
110112 f <- holdDyn False eChangeFocus
111− ev <- wrapDomEvent e elementOninput $ liftIO $ htmlTextAreaElementGetValue e
113+ ev <- wrapDomEvent e (`on` input) $ fromMaybe "" <$> TextArea.getValue e
112114 v <- holdDyn initial $ leftmost [eSet, ev]
113− eKeypress <- wrapDomEvent e elementOnkeypress getKeyEvent
115+ eKeypress <- wrapDomEvent e (`on` keyPress) getKeyEvent
114116 return $ TextArea v ev e f eKeypress
115117
116118data CheckboxConfig t
@@ -135,21 +137,21 @@ checkbox :: MonadWidget t m => Bool -> CheckboxConfig t -> m (Checkbox t)
135137checkbox checked config = do
136138 attrs <- mapDyn (\c -> Map.insert "type" "checkbox" $ (if checked then Map.insert "checked" "checked" else Map.delete "checked") c) (_checkboxConfig_attributes config)
137139 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
140+ eClick <- wrapDomEvent e (`on` click) $ Input.getChecked e
141+ performEvent_ $ fmap (\v -> Input.setChecked e $! v) $ _checkboxConfig_setValue config
140142 dValue <- holdDyn checked $ leftmost [_checkboxConfig_setValue config, eClick]
141143 return $ Checkbox dValue eClick
142144
143145checkboxView :: MonadWidget t m => Dynamic t (Map String String) -> Dynamic t Bool -> m (Event t Bool)
144146checkboxView dAttrs dValue = do
145147 e <- liftM castToHTMLInputElement $ buildEmptyElement "input" =<< mapDyn (Map.insert "type" "checkbox") dAttrs
146− eClicked <- wrapDomEvent e elementOnclick $ do
148+ eClicked <- wrapDomEvent e (`on` click) $ do
147149 preventDefault
148− liftIO $ htmlInputElementGetChecked e
150+ Input.getChecked e
149151 schedulePostBuild $ do
150152 v <- sample $ current dValue
151− when v $ liftIO $ htmlInputElementSetChecked e True
152− performEvent_ $ fmap (\v -> liftIO $ htmlInputElementSetChecked e $! v) $ updated dValue
153+ when v $ Input.setChecked e True
154+ performEvent_ $ fmap (\v -> Input.setChecked e $! v) $ updated dValue
153155 return eClicked
154156
155157data FileInput t
@@ -168,10 +170,10 @@ instance Reflex t => Default (FileInputConfig t) where
168170fileInput :: MonadWidget t m => FileInputConfig t -> m (FileInput t)
169171fileInput (FileInputConfig dAttrs) = do
170172 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]
173+ eChange <- wrapDomEvent e (flip on change) $ do
174+ Just files <- getFiles e
175+ len <- FileList.getLength files
176+ mapM (liftM (fromMaybe (error "fileInput: fileListItem returned null")) . FileList.item files) $ init [0..len]
175177 dValue <- holdDyn [] eChange
176178 return $ FileInput dValue e
177179
@@ -191,26 +193,29 @@ instance (Reflex t, Ord k, Show k, Read k) => Default (DropdownConfig t k) where
191193 }
192194
193195--TODO: We should allow the user to specify an ordering instead of relying on the ordering of the Map
194−--TODO: Get rid of Show k and Read k by indexing the possible values ourselves
195196-- | Create a dropdown box
196197-- The first argument gives the initial value of the dropdown; if it is not present in the map of options provided, it will be added with an empty string as its text
197−dropdown :: forall k t m. (MonadWidget t m, Ord k, Show k, Read k) => k -> Dynamic t (Map k String) -> DropdownConfig t k -> m (Dropdown t k)
198+dropdown :: forall k t m. (MonadWidget t m, Ord k) => k -> Dynamic t (Map k String) -> DropdownConfig t k -> m (Dropdown t k)
198199dropdown k0 options (DropdownConfig setK attrs) = do
199− (eRaw, _) <- elDynAttr' "select" attrs $ do
200− optionsWithDefault <- mapDyn (`Map.union` (k0 =: "")) options
201− listWithKey optionsWithDefault $ \k v -> do
202− elAttr "option" ("value" =: show k <> if k == k0 then "selected" =: "selected" else mempty) $ dynText v
200+ optionsWithAddedKeys <- combineDyn Map.union options <=< foldDyn Map.union (k0 =: "") $ fmap (=: "") setK
201+ defaultKey <- holdDyn k0 setK
202+ (indexedOptions, ixKeys) <- splitDyn <=< forDyn optionsWithAddedKeys $ \os ->
203+ let xs = map (\(ix, (k, v)) -> ((ix, k), ((ix, k), v))) $ zip [0::Int ..] $ Map.toList os
204+ ixVals = Map.fromList $ map snd xs
205+ ixKeys = B.fromList $ map fst xs
206+ in (ixVals, ixKeys)
207+ (eRaw, _) <- elDynAttr' "select" attrs $ listWithKey indexedOptions $ \(ix, k) v -> do
208+ optionAttrs <- mapDyn (\dk -> "value" =: show ix <> if dk == k then "selected" =: "selected" else mempty) defaultKey
209+ elDynAttr "option" optionAttrs $ dynText v
203210 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
207− return $ readMay kStr
208− let readKey opts mk = fromMaybe k0 $ do
211+ performEvent_ $ fmap (Select.setValue e . Just . show) $ attachDynWithMaybe (flip B.lookupR) ixKeys setK
212+ eChange <- attachDynWith (\ks s -> join $ B.lookup <$> join (readMaybe <$> s) <*> pure ks) ixKeys <$> (wrapDomEvent e (`on` change) $ Select.getValue e)
213+ let readKey keys mk = fromMaybe k0 $ do
209214 k <- mk
210− guard $ Map.member k opts
215+ guard $ B.memberR k keys
211216 return k
212− dValue <- combineDyn readKey options =<< holdDyn (Just k0) (leftmost [eChange, fmap Just setK])
213− return $ Dropdown dValue (attachDynWith readKey options eChange)
217+ dValue <- combineDyn readKey ixKeys <=< holdDyn (Just k0) $ leftmost [eChange, fmap Just setK]
218+ return $ Dropdown dValue (attachDynWith readKey ixKeys eChange)
214219
215220liftM concat $ mapM makeLenses
216221 [ ''TextAreaConfig
@@ -320,4 +325,3 @@ instance HasStateModeWitness Edit where
320325instance HasStateModeWitness View where
321326 stateModeWitness = ViewWitness
322327-}
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+19−18
@@ -8,7 +8,8 @@ import Reflex.Dom.Widget.Basic
88import Control.Monad
99import Control.Monad.IO.Class
1010import Data.Monoid
11−import GHCJS.DOM.Element
11+import GHCJS.DOM.Element hiding (reset)
12+import GHCJS.DOM.EventM (on)
1213
1314-- | A widget that wraps the given widget in a div and fires an event when resized.
1415-- Adapted from github.com/marcj/css-element-queries
@@ -31,31 +32,31 @@ resizeDetectorWithStyle styleString w = do
3132 let reset = do
3233 let e = _el_element expand
3334 s = _el_element shrink
34− eow <- elementGetOffsetWidth e
35− eoh <- elementGetOffsetHeight e
35+ eow <- getOffsetWidth e
36+ eoh <- getOffsetHeight e
3637 let ecw = eow + 10
3738 ech = eoh + 10
38− elementSetAttribute (_el_element expandChild) "style" (childStyle <> "width: " <> show ecw <> "px;" <> "height: " <> show ech <> "px;")
39− esw <- elementGetScrollWidth e
40− elementSetScrollLeft e esw
41− esh <- elementGetScrollHeight e
42− elementSetScrollTop e esh
43− ssw <- elementGetScrollWidth s
44− elementSetScrollLeft s ssw
45− ssh <- elementGetScrollHeight s
46− elementSetScrollTop s ssh
47− lastWidth <- elementGetOffsetWidth (_el_element parent)
48− lastHeight <- elementGetOffsetHeight (_el_element parent)
39+ setAttribute (_el_element expandChild) "style" (childStyle <> "width: " <> show ecw <> "px;" <> "height: " <> show ech <> "px;")
40+ esw <- getScrollWidth e
41+ setScrollLeft e esw
42+ esh <- getScrollHeight e
43+ setScrollTop e esh
44+ ssw <- getScrollWidth s
45+ setScrollLeft s ssw
46+ ssh <- getScrollHeight s
47+ setScrollTop s ssh
48+ lastWidth <- getOffsetWidth (_el_element parent)
49+ lastHeight <- getOffsetHeight (_el_element parent)
4950 return (Just lastWidth, Just lastHeight)
5051 resetIfChanged ds = do
51− pow <- elementGetOffsetWidth (_el_element parent)
52− poh <- elementGetOffsetHeight (_el_element parent)
52+ pow <- getOffsetWidth (_el_element parent)
53+ poh <- getOffsetHeight (_el_element parent)
5354 if ds == (Just pow, Just poh)
5455 then return Nothing
5556 else liftM Just reset
5657 pb <- getPostBuild
57− expandScroll <- wrapDomEvent (_el_element expand) elementOnscroll $ return ()
58− shrinkScroll <- wrapDomEvent (_el_element shrink) elementOnscroll $ return ()
58+ expandScroll <- wrapDomEvent (_el_element expand) (`on` scroll) $ return ()
59+ shrinkScroll <- wrapDomEvent (_el_element shrink) (`on` scroll) $ return ()
5960 size0 <- performEvent $ fmap (const $ liftIO reset) pb
6061 rec resize <- performEventAsync $ fmap (\d cb -> liftIO $ cb =<< resetIfChanged d) $ tag (current dimensions) $ leftmost [expandScroll, shrinkScroll]
6162 dimensions <- holdDyn (Nothing, Nothing) $ leftmost [ size0, fmapMaybe id resize ]
src/Reflex/Dom/Xhr.hs+107−25
@@ -1,9 +1,27 @@
11{-# LANGUAGE DeriveDataTypeable #-}
22
33module Reflex.Dom.Xhr
4− ( module Reflex.Dom.Xhr
5− , XMLHttpRequest
6− , responseTextToText
4+ ( XMLHttpRequest
5+ , XhrRequest(..)
6+ , XhrRequestConfig(..)
7+ , XhrResponse(..)
8+ , XhrResponseBody(..)
9+ , XhrResponseType(..)
10+ , XhrException(..)
11+ , _xhrResponse_body
12+ , xhrResponse_body
13+ , xhrRequest
14+ , newXMLHttpRequest
15+ , newXMLHttpRequestWithError
16+ , performRequestAsync
17+ , performRequestAsyncWithError
18+ , performRequestsAsync
19+ , performRequestsAsyncWithError
20+ , getAndDecode
21+ , postJson
22+ , getMay
23+ , decodeText
24+ , decodeXhrResponse
725 , xmlHttpRequestGetReadyState
826 , xmlHttpRequestGetResponseText
927 , xmlHttpRequestGetStatus
@@ -18,6 +36,7 @@ module Reflex.Dom.Xhr
1836where
1937
2038import Control.Concurrent
39+import Control.Exception (catch)
2140import Control.Lens
2241import Control.Monad hiding (forM)
2342import Control.Monad.IO.Class
@@ -35,7 +54,9 @@ import Data.Text.Encoding
3554import Data.Traversable
3655import Reflex
3756import Reflex.Dom.Class
57+import Reflex.Dom.Xhr.Exception
3858import Reflex.Dom.Xhr.Foreign
59+import Reflex.Dom.Xhr.ResponseType
3960import Data.Typeable
4061
4162data XhrRequest
@@ -49,17 +70,26 @@ data XhrRequestConfig
4970 = XhrRequestConfig { _xhrRequestConfig_headers :: Map String String
5071 , _xhrRequestConfig_user :: Maybe String
5172 , _xhrRequestConfig_password :: Maybe String
52− , _xhrRequestConfig_responseType :: Maybe String
73+ , _xhrRequestConfig_responseType :: Maybe XhrResponseType
5374 , _xhrRequestConfig_sendData :: Maybe String
5475 }
5576 deriving (Show, Read, Eq, Ord, Typeable)
5677
5778data XhrResponse
58− = XhrResponse { _xhrResponse_body :: Maybe Text
59− , _xhrResponse_status :: Word
79+ = XhrResponse { _xhrResponse_status :: Word
6080 , _xhrResponse_statusText :: Text
81+ , _xhrResponse_response :: Maybe XhrResponseBody
82+ , _xhrResponse_responseText :: Maybe Text
6183 }
62− deriving (Show, Read, Eq, Ord, Typeable)
84+ deriving (Typeable)
85+
86+{-# DEPRECATED _xhrResponse_body "Use _xhrResponse_response or _xhrResponse_responseText instead." #-}
87+_xhrResponse_body :: XhrResponse -> Maybe Text
88+_xhrResponse_body = _xhrResponse_responseText
89+
90+{-# DEPRECATED xhrResponse_body "Use xhrResponse_response or xhrResponse_responseText instead." #-}
91+xhrResponse_body :: Lens XhrResponse XhrResponse (Maybe Text) (Maybe Text)
92+xhrResponse_body = lens _xhrResponse_responseText (\r t -> r { _xhrResponse_responseText = t })
6393
6494instance Default XhrRequestConfig where
6595 def = XhrRequestConfig { _xhrRequestConfig_headers = Map.empty
@@ -73,13 +103,26 @@ instance Default XhrRequestConfig where
73103xhrRequest :: String -> String -> XhrRequestConfig -> XhrRequest
74104xhrRequest = XhrRequest
75105
76−newXMLHttpRequest :: (HasWebView m, MonadIO m, HasPostGui t h m) => XhrRequest -> (XhrResponse -> h ()) -> m XMLHttpRequest
77−newXMLHttpRequest req cb = do
106+-- | Make a new asyncronous XHR request. This does not block (it forks),
107+-- and returns an XHR object immediately (which you can use to abort
108+-- the XHR connection), and will pass an exception ('XhrException') to the
109+-- continuation if the connection cannot be made (or is aborted).
110+newXMLHttpRequestWithError
111+ :: (HasWebView m, MonadIO m, HasPostGui t h m)
112+ => XhrRequest
113+ -- ^ The request to make.
114+ -> (Either XhrException XhrResponse -> h ())
115+ -- ^ A continuation to be called once a response comes back, or in
116+ -- case of error.
117+ -> m XMLHttpRequest
118+ -- ^ The XHR request, which could for example be aborted.
119+newXMLHttpRequestWithError req cb = do
78120 wv <- askWebView
79121 postGui <- askPostGui
80− liftIO $ do
81− xhr <- xmlHttpRequestNew wv
122+ xhr <- liftIO $ xmlHttpRequestNew wv
123+ void $ liftIO $ forkIO $ flip catch (postGui . cb . Left) $ void $ do
82124 let c = _xhrRequest_config req
125+ rt = _xhrRequestConfig_responseType c
83126 xmlHttpRequestOpen
84127 xhr
85128 (_xhrRequest_method req)
@@ -88,32 +131,71 @@ newXMLHttpRequest req cb = do
88131 (fromMaybe "" $ _xhrRequestConfig_user c)
89132 (fromMaybe "" $ _xhrRequestConfig_password c)
90133 iforM_ (_xhrRequestConfig_headers c) $ xmlHttpRequestSetRequestHeader xhr
91− maybe (return ()) (xmlHttpRequestSetResponseType xhr . toResponseType) (_xhrRequestConfig_responseType c)
134+ maybe (return ()) (xmlHttpRequestSetResponseType xhr . fromResponseType) rt
92135 _ <- xmlHttpRequestOnreadystatechange xhr $ do
93136 readyState <- liftIO $ xmlHttpRequestGetReadyState xhr
94137 status <- liftIO $ xmlHttpRequestGetStatus xhr
95138 statusText <- liftIO $ xmlHttpRequestGetStatusText xhr
96139 if readyState == 4
97140 then do
98− r <- liftIO $ xmlHttpRequestGetResponseText xhr
99− _ <- liftIO $ postGui $ cb $ XhrResponse (responseTextToText r) status (statusTextToText statusText)
141+ t <- if rt == Just XhrResponseType_Text || rt == Nothing
142+ then liftIO $ xmlHttpRequestGetResponseText xhr
143+ else return Nothing
144+ r <- liftIO $ xmlHttpRequestGetResponse xhr
145+ _ <- liftIO $ postGui $ cb $ Right $
146+ XhrResponse { _xhrResponse_status = status
147+ , _xhrResponse_statusText = statusText
148+ , _xhrResponse_response = r
149+ , _xhrResponse_responseText = t
150+ }
100151 return ()
101152 else return ()
102153 _ <- xmlHttpRequestSend xhr (_xhrRequestConfig_sendData c)
103− return xhr
154+ return ()
155+ return xhr
156+
157+newXMLHttpRequest :: (HasWebView m, MonadIO m, HasPostGui t h m) => XhrRequest -> (XhrResponse -> h ()) -> m XMLHttpRequest
158+newXMLHttpRequest req cb = newXMLHttpRequestWithError req $ mapM_ cb
159+
160+-- | Given Event of requests, issue them when the Event fires.
161+-- Returns Event of corresponding responses.
162+--
163+-- The request is processed asynchronously, therefore handling does
164+-- not block or cause a delay while creating the connection.
165+performRequestAsyncWithError
166+ :: MonadWidget t m
167+ => Event t XhrRequest -> m (Event t (Either XhrException XhrResponse))
168+performRequestAsyncWithError = performRequestAsync' newXMLHttpRequestWithError
169+
170+performRequestAsync :: MonadWidget t m => Event t XhrRequest -> m (Event t XhrResponse)
171+performRequestAsync = performRequestAsync' newXMLHttpRequest
172+
173+performRequestAsync' :: (MonadWidget t m, MonadIO h) => (XhrRequest -> (a -> h ()) -> WidgetHost m XMLHttpRequest) -> Event t XhrRequest -> m (Event t a)
174+performRequestAsync' newXhr req = performEventAsync $ ffor req $ \r cb -> void $ newXhr r $ liftIO . cb
175+
176+-- | Issues a collection of requests when the supplied Event fires.
177+-- When ALL requests from a given firing complete, the results are
178+-- collected and returned via the return Event.
179+--
180+-- The requests are processed asynchronously, therefore handling does
181+-- not block or cause a delay while creating the connection.
182+--
183+-- Order of request execution and completion is not guaranteed, but
184+-- order of creation and the collection result is preserved.
185+performRequestsAsyncWithError
186+ :: (Traversable f, MonadWidget t m)
187+ => Event t (f XhrRequest) -> m (Event t (f (Either XhrException XhrResponse)))
188+performRequestsAsyncWithError = performRequestsAsync' newXMLHttpRequestWithError
104189
105−-- | Given Event of requests, issue them when the Event fires. Returns Event of corresponding responses.
106−performRequestAsync :: (MonadWidget t m) => Event t XhrRequest -> m (Event t XhrResponse)
107−performRequestAsync req = performEventAsync $ ffor req $ \r cb -> do
108− _ <- newXMLHttpRequest r $ liftIO . cb
109− return ()
110190
111−-- | Issues a collection of requests when the supplied Event fires. When ALL requests from a given firing complete, the results are collected and returned via the return Event.
112191performRequestsAsync :: (Traversable f, MonadWidget t m) => Event t (f XhrRequest) -> m (Event t (f XhrResponse))
113−performRequestsAsync req = performEventAsync $ ffor req $ \rs cb -> do
192+performRequestsAsync = performRequestsAsync' newXMLHttpRequest
193+
194+performRequestsAsync' :: (MonadWidget t m, MonadIO h, Traversable f) => (XhrRequest -> (a -> h ()) -> WidgetHost m XMLHttpRequest) -> Event t (f XhrRequest) -> m (Event t (f a))
195+performRequestsAsync' newXhr req = performEventAsync $ ffor req $ \rs cb -> do
114196 resps <- forM rs $ \r -> do
115197 resp <- liftIO newEmptyMVar
116− _ <- newXMLHttpRequest r $ liftIO . putMVar resp
198+ _ <- newXhr r $ liftIO . putMVar resp
117199 return resp
118200 _ <- liftIO $ forkIO $ cb =<< forM resps takeMVar
119201 return ()
@@ -126,7 +208,7 @@ getAndDecode url = do
126208
127209-- | Create a "POST" request from an URL and thing with a JSON representation
128210postJson :: (ToJSON a) => String -> a -> XhrRequest
129−postJson url a =
211+postJson url a =
130212 XhrRequest "POST" url $ def { _xhrRequestConfig_headers = headerUrlEnc
131213 , _xhrRequestConfig_sendData = Just body
132214 }
@@ -143,5 +225,5 @@ decodeText = decode . BL.fromStrict . encodeUtf8
143225
144226-- | Convenience function to decode JSON-encoded responses.
145227decodeXhrResponse :: FromJSON a => XhrResponse -> Maybe a
146−decodeXhrResponse = join . fmap decodeText . _xhrResponse_body
228+decodeXhrResponse = join . fmap decodeText . _xhrResponse_responseText
147229
src/Reflex/Dom/Xhr/Exception.hsnew file+12
@@ -0,0 +1,12 @@
1+{-# LANGUAGE DeriveDataTypeable #-}
2+
3+module Reflex.Dom.Xhr.Exception where
4+
5+import Data.Typeable
6+import Control.Exception (Exception(..))
7+
8+data XhrException = XhrException_Error
9+ | XhrException_Aborted
10+ deriving (Show, Read, Eq, Ord, Typeable)
11+
12+instance Exception XhrException
src/Reflex/Dom/Xhr/ResponseType.hsnew file+21
@@ -0,0 +1,21 @@
1+{-# LANGUAGE DeriveDataTypeable #-}
2+
3+module Reflex.Dom.Xhr.ResponseType where
4+
5+import Data.Typeable
6+import Data.Text (Text)
7+import GHCJS.DOM.Blob (Blob)
8+import Data.ByteString (ByteString)
9+
10+data XhrResponseType = XhrResponseType_Default
11+ | XhrResponseType_ArrayBuffer
12+ | XhrResponseType_Blob
13+ | XhrResponseType_Text
14+ deriving (Show, Read, Eq, Ord, Typeable)
15+
16+data XhrResponseBody = XhrResponseBody_Default Text
17+ | XhrResponseBody_Text Text
18+ | XhrResponseBody_Blob Blob
19+ | XhrResponseBody_ArrayBuffer ByteString
20+ deriving (Eq)
21+
test/BrokenHaltSpec.hsnew file+40
@@ -0,0 +1,40 @@
1+{-# LANGUAGE FlexibleContexts #-}
2+
3+module HaltSpec where
4+
5+import Control.Monad.IO.Class
6+import Data.Foldable
7+import GHCJS.DOM
8+import qualified Graphics.UI.Gtk as Gtk
9+import Reflex.Dom
10+import Reflex.Spider.Internal (SpiderHostFrame)
11+import Test.Hspec
12+
13+spec :: Spec
14+spec = do
15+ describe "haltGui" $ do
16+ it "works" $ do
17+ getFirstEventAndHalt return `shouldReturn` ()
18+
19+ it "works multiple times" $ do
20+ forM_ [1 .. 100] $ \ i -> do
21+ getFirstEventAndHalt return `shouldReturn` ()
22+
23+type SpiderM =
24+ Widget Spider (Gui Spider (WithWebView SpiderHost) SpiderHostFrame)
25+
26+getFirstEventAndHalt :: (Event Spider () -> SpiderM (Event Spider ())) -> IO ()
27+getFirstEventAndHalt action = do
28+ _ <- mainWidget $ do
29+ tick <- getPostBuild
30+ event <- action tick
31+ webView <- askWebView
32+ _ <- foldDynM (\ a () -> liftIO $ haltGui webView) () event
33+ return ()
34+ return ()
35+
36+haltGui :: WebView -> IO ()
37+haltGui wv = do
38+ Gtk.postGUIAsync $ do
39+ w <- Gtk.widgetGetToplevel wv
40+ Gtk.widgetDestroy w
test/HaltSpec.hsnew file+29
@@ -0,0 +1,29 @@
1+{-# LANGUAGE FlexibleContexts #-}
2+
3+import Control.Monad.IO.Class
4+import Data.Foldable
5+import GHCJS.DOM
6+import qualified Graphics.UI.Gtk as Gtk
7+import Reflex.Dom
8+import Reflex.Spider.Internal (SpiderHostFrame)
9+
10+main = do
11+ getFirstEventAndHalt return
12+ putStrLn "stopped once"
13+
14+ forM_ [1 .. 1000] $ \ i -> do
15+ getFirstEventAndHalt return
16+ putStrLn "stopped many times"
17+
18+type SpiderM = Widget Spider (Gui Spider (WithWebView SpiderHost) SpiderHostFrame)
19+
20+getFirstEventAndHalt :: (Event Spider () -> SpiderM (Event Spider ())) -> IO ()
21+getFirstEventAndHalt action = do
22+ _ <- mainWidget $ do
23+ tick <- getPostBuild
24+ event <- action tick
25+ webView <- askWebView
26+ quit <- getQuitWidget
27+ performEvent_ (quit <$ event)
28+ return ()
29+ return ()