packages feed

reflex-dom 0.2 → 0.3

raw patch · 21 files changed

+1419/−869 lines, 21 filesdep +raw-strings-qqdep +unixdep ~aesondep ~bifunctorsdep ~dependent-map

Dependencies added: raw-strings-qq, unix

Dependency ranges changed: aeson, bifunctors, dependent-map, dependent-sum, ghcjs-dom, gtk3, reflex, semigroups, time, transformers, webkitgtk3

Files

reflex-dom.cabal view
@@ -1,5 +1,5 @@ Name: reflex-dom-Version: 0.2+Version: 0.3 Synopsis: Functional Reactive Web Apps with Reflex Description: Reflex-DOM is a Functional Reactive web framework based on the Reflex FRP engine License: BSD3@@ -13,64 +13,76 @@ -- Deal with https://github.com/haskell/cabal/issues/2544 / https://github.com/haskell/cabal/issues/367 extra-source-files: src-ghc/Reflex/Dom/Internal/Foreign.hs                     src-ghc/Reflex/Dom/Xhr/Foreign.hs+                    src-ghc/Reflex/Dom/WebSocket/Foreign.hs                     src-ghcjs/Reflex/Dom/Internal/Foreign.hs                     src-ghcjs/Reflex/Dom/Xhr/Foreign.hs+                    src-ghcjs/Reflex/Dom/WebSocket/Foreign.hs+                    src/Reflex/Dom/Xhr/ResponseType.hs+                    src/Reflex/Dom/Xhr/Exception.hs  library   hs-source-dirs: src   build-depends:     base >= 4.7 && < 4.9,-    reflex == 0.3.*,-    dependent-sum == 0.2.*,-    dependent-map == 0.1.*,-    semigroups == 0.16.*,+    reflex == 0.4.*,+    dependent-sum == 0.3.*,+    dependent-map == 0.2.*,+    semigroups >= 0.16 && < 0.19,     mtl >= 2.1 && < 2.3,     containers == 0.5.*,-    these == 0.4.*,+    these >= 0.4 && < 0.7,     ref-tf == 0.4.*,-    transformers == 0.4.*,-    lens >= 4.7 && < 4.10,-    ghcjs-dom >= 0.1.1.3 && < 0.2,+    ghcjs-dom >= 0.2.1 && < 0.3,+    transformers == 0.3.* || == 0.4.*,+    lens >= 4.7 && < 4.14,     safe == 0.3.*,     text == 1.2.*,     bytestring == 0.10.*,     data-default == 0.5.*,-    aeson == 0.8.*,-    time == 1.5.*,+    aeson >= 0.8 && < 0.11,+    time == 1.4.* || == 1.5.*,     exception-transformers == 0.4.*,     directory == 1.2.*,     dependent-sum-template >= 0.0.0.4 && < 0.1,-    bifunctors == 4.2.*+    bifunctors >= 4.2 && < 6    if impl(ghcjs)     hs-source-dirs: src-ghcjs-    cpp-options: -D__GHCJS__     build-depends:       ghcjs-base   else     hs-source-dirs: src-ghc     build-depends:       glib == 0.13.*,-      gtk3 == 0.13.*,-      webkitgtk3 == 0.13.*,-      webkitgtk3-javascriptcore == 0.13.*+      gtk3 >= 0.13.0 && < 0.15,+      webkitgtk3 == 0.14.*,+      webkitgtk3-javascriptcore == 0.13.*,+      raw-strings-qq+    if !os(windows)+      build-depends: unix == 2.7.*    exposed-modules:     Reflex.Dom     Reflex.Dom.Class     Reflex.Dom.Internal+    Reflex.Dom.Time+    Reflex.Dom.WebSocket     Reflex.Dom.Widget     Reflex.Dom.Widget.Basic     Reflex.Dom.Widget.Input     Reflex.Dom.Widget.Lazy+    Reflex.Dom.Widget.Resize     Reflex.Dom.Xhr-    Reflex.Dom.Time+    Reflex.Dom.Location   other-modules:     Reflex.Dom.Internal.Foreign+    Reflex.Dom.WebSocket.Foreign     Reflex.Dom.Xhr.Foreign+    Reflex.Dom.Xhr.ResponseType+    Reflex.Dom.Xhr.Exception    other-extensions: TemplateHaskell-  ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2+  ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 -ferror-spans  source-repository head   type: git
src-ghc/Reflex/Dom/Internal/Foreign.hs view
@@ -1,21 +1,48 @@-{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE CPP, ForeignFunctionInterface, ScopedTypeVariables, LambdaCase #-} module Reflex.Dom.Internal.Foreign where -import GHCJS.DOM hiding (runWebGUI) import Control.Concurrent+import Control.Exception (bracket)+import Control.Lens hiding (set)+import Control.Monad import Control.Monad.State.Strict hiding (mapM, mapM_, forM, forM_, sequence, sequence_, get)+import Data.ByteString (ByteString)+import Data.List+import Foreign.Marshal hiding (void)+import Foreign.Ptr+import GHCJS.DOM hiding (runWebGUI) import GHCJS.DOM.Navigator-import GHCJS.DOM.DOMWindow+import GHCJS.DOM.Window import Graphics.UI.Gtk hiding (Widget)-import Graphics.UI.Gtk.WebKit.WebView-import Graphics.UI.Gtk.WebKit.Types hiding (Event, Widget, unWidget)-import Graphics.UI.Gtk.WebKit.WebSettings+import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSBase+import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSObjectRef+import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSStringRef+import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSValueRef+import Graphics.UI.Gtk.WebKit.JavaScriptCore.WebFrame+import Graphics.UI.Gtk.WebKit.Types hiding (Event, Widget) import Graphics.UI.Gtk.WebKit.WebFrame import Graphics.UI.Gtk.WebKit.WebInspector-import Data.List-import Data.String+import Graphics.UI.Gtk.WebKit.WebSettings+import Graphics.UI.Gtk.WebKit.WebView import System.Directory+import System.Glib.FFI hiding (void)+import qualified Data.ByteString as BS +#ifndef mingw32_HOST_OS+import System.Posix.Signals+#endif++quitWebView :: WebView -> IO ()+quitWebView wv = postGUIAsync $ do w <- widgetGetToplevel wv+                                   widgetDestroy w++installQuitHandler :: WebView -> IO ()+#ifdef mingw32_HOST_OS+installQuitHandler wv = return () -- TODO: Maybe figure something out here for Windows users.+#else+installQuitHandler wv = installHandler keyboardSignal (Catch (quitWebView wv)) Nothing >> return ()+#endif+ makeDefaultWebView :: String -> (WebView -> IO ()) -> IO () makeDefaultWebView userAgentKey main = do   _ <- initGUI@@ -39,7 +66,7 @@   _ <- webView `on` loadFinished $ \_ -> do     main webView --TODO: Should probably only do this once   inspector <- webViewGetInspector webView-  _ <- inspector `on` inspectWebView $ \wv -> do+  _ <- inspector `on` inspectWebView $ \_ -> do     inspectorWindow <- windowNew     windowSetDefaultSize inspectorWindow 900 600     inspectorScrollWin <- scrolledWindowNew Nothing Nothing@@ -51,6 +78,7 @@   wf <- webViewGetMainFrame webView   pwd <- getCurrentDirectory   webFrameLoadString wf "" Nothing $ "file://" ++ pwd ++ "/"+  installQuitHandler webView   mainGUI  runWebGUI :: (WebView -> IO ()) -> IO ()@@ -63,8 +91,73 @@   case mbWindow of     Just window -> do       -- Check if we are running in javascript inside the the native version-      Just n <- domWindowGetNavigator window-      agent <- navigatorGetUserAgent n+      Just n <- getNavigator window+      agent <- getUserAgent n       unless ((" " ++ userAgentKey) `isSuffixOf` agent) $ main (castToWebView window)     Nothing -> do       makeDefaultWebView userAgentKey main++foreign import ccall "wrapper"+  wrapper :: JSObjectCallAsFunctionCallback' -> IO JSObjectCallAsFunctionCallback++toJSObject :: JSContextRef -> [Ptr OpaqueJSValue] -> IO JSObjectRef+toJSObject ctx args = do+  o <- jsobjectmake ctx nullPtr nullPtr+  iforM_ args $ \n a -> do+    prop <- jsstringcreatewithutf8cstring $ show n+    jsobjectsetproperty ctx o prop a 1 nullPtr+  return o++fromJSStringMaybe :: JSContextRef -> JSValueRef -> IO (Maybe String)+fromJSStringMaybe c t = do+  isNull <- jsvalueisnull c t+  case isNull of+    True -> return Nothing+    False -> do+      j <- jsvaluetostringcopy c t nullPtr+      l <- jsstringgetmaximumutf8cstringsize j+      s <- allocaBytes (fromIntegral l) $ \ps -> do+             _ <- jsstringgetutf8cstring'_ j ps (fromIntegral l)+             peekCString ps+      return $ Just s++getLocationHost :: WebView -> IO String+getLocationHost wv = withWebViewContext wv $ \c -> do+  script <- jsstringcreatewithutf8cstring "location.host"+  lh <- jsevaluatescript c script nullPtr nullPtr 1 nullPtr+  lh' <- fromJSStringMaybe c lh+  return $ maybe "" id lh'++getLocationProtocol :: WebView -> IO String+getLocationProtocol wv = withWebViewContext wv $ \c -> do+  script <- jsstringcreatewithutf8cstring "location.protocol"+  lp <- jsevaluatescript c script nullPtr nullPtr 1 nullPtr+  lp' <- fromJSStringMaybe c lp+  return $ maybe "" id lp'++bsToArrayBuffer :: JSContextRef -> ByteString -> IO JSValueRef+bsToArrayBuffer c bs = do+  elems <- forM (BS.unpack bs) $ \x -> jsvaluemakenumber c $ fromIntegral x+  let numElems = length elems+  bracket (mallocArray numElems) free $ \elemsArr -> do+    pokeArray elemsArr elems+    a <- jsobjectmakearray c (fromIntegral numElems) elemsArr nullPtr+    newUint8Array <- jsstringcreatewithutf8cstring "new Uint8Array(this)"+    jsevaluatescript c newUint8Array a nullPtr 1 nullPtr++bsFromArrayBuffer :: JSContextRef -> JSValueRef -> IO ByteString+bsFromArrayBuffer c a = do+  let getIntegral = fmap round . (\x -> jsvaluetonumber c x nullPtr)+  getByteLength <- jsstringcreatewithutf8cstring "this.byteLength"+  byteLength <- getIntegral =<< jsevaluatescript c getByteLength a nullPtr 1 nullPtr+  toUint8Array <- jsstringcreatewithutf8cstring "new Uint8Array(this)"+  uint8Array <- jsevaluatescript c toUint8Array a nullPtr 1 nullPtr+  getIx <- jsstringcreatewithutf8cstring "this[0][this[1]]"+  let arrayLookup i = do+        i' <- jsvaluemakenumber c (fromIntegral i)+        args <- toJSObject c [uint8Array, i']+        getIntegral =<< jsevaluatescript c getIx args nullPtr 1 nullPtr+  fmap BS.pack $ forM [0..byteLength-1] arrayLookup++withWebViewContext :: WebView -> (JSContextRef -> IO a) -> IO a+withWebViewContext wv f = f =<< webFrameGetGlobalContext =<< webViewGetMainFrame wv
+ src-ghc/Reflex/Dom/WebSocket/Foreign.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI, CPP, TemplateHaskell, NoMonomorphismRestriction, EmptyDataDecls, RankNTypes, GADTs, RecursiveDo, ScopedTypeVariables, FlexibleInstances, MultiParamTypeClasses, TypeFamilies, FlexibleContexts, DeriveDataTypeable, GeneralizedNewtypeDeriving, StandaloneDeriving, ConstraintKinds, UndecidableInstances, PolyKinds, AllowAmbiguousTypes #-}++module Reflex.Dom.WebSocket.Foreign where++import Prelude hiding (div, span, mapM, mapM_, concat, concatMap, all, sequence)++import Control.Exception+import Control.Monad.State+import Data.ByteString (ByteString)+import Data.Text.Encoding+import Foreign.Marshal hiding (void)+import Foreign.Ptr+import Foreign.Storable+import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSBase+import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSObjectRef+import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSStringRef+import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSValueRef+import Graphics.UI.Gtk.WebKit.WebView+import qualified Data.ByteString as BS+import qualified Data.Text as T++import Reflex.Dom.Internal.Foreign++data JSWebSocket = JSWebSocket { wsValue :: JSValueRef+                               , wsContext :: JSContextRef+                               }++newWebSocket :: WebView -> String -> (ByteString -> IO ()) -> IO () -> IO () -> IO JSWebSocket+newWebSocket wv url onMessage onOpen onClose = withWebViewContext wv $ \c -> do+  url' <- jsvaluemakestring c =<< jsstringcreatewithutf8cstring url+  newWSArgs <- toJSObject c [url']+  newWS <- jsstringcreatewithutf8cstring "(function(that) { var ws = new WebSocket(that[0]); ws['binaryType'] = 'arraybuffer'; return ws; })(this)"+  ws <- jsevaluatescript c newWS newWSArgs nullPtr 1 nullPtr+  onMessage' <- wrapper $ \_ _ _ _ args _ -> do+    e <- peekElemOff args 0+    dataProp <- jsstringcreatewithutf8cstring "data"+    msg <- jsobjectgetproperty c e dataProp nullPtr+    msg' <- fromJSStringMaybe c msg+    case msg' of+      Nothing -> return ()+      Just m -> onMessage $ encodeUtf8 $ T.pack m+    jsvaluemakeundefined c+  onMessageCb <- jsobjectmakefunctionwithcallback c nullPtr onMessage'+  onOpen' <- wrapper $ \_ _ _ _ _ _ -> do+    onOpen+    jsvaluemakeundefined c+  onOpenCb <- jsobjectmakefunctionwithcallback c nullPtr onOpen'+  onClose' <- wrapper $ \_ _ _ _ _ _ -> do+    onClose+    jsvaluemakeundefined c+  onCloseCb <- jsobjectmakefunctionwithcallback c nullPtr onClose'+  o <- toJSObject c [ws, onMessageCb, onOpenCb, onCloseCb]+  addCbs <- jsstringcreatewithutf8cstring "this[0]['onmessage'] = this[1]; this[0]['onopen'] = this[2]; this[0]['onclose'] = this[3];"+  _ <- jsevaluatescript c addCbs o nullPtr 1 nullPtr+  return $ JSWebSocket ws c++webSocketSend :: JSWebSocket -> ByteString -> IO ()+webSocketSend (JSWebSocket ws c) bs = do+  elems <- forM (BS.unpack bs) $ \x -> jsvaluemakenumber c $ fromIntegral x+  let numElems = length elems+  bs' <- bracket (mallocArray numElems) free $ \elemsArr -> do+    pokeArray elemsArr elems+    a <- jsobjectmakearray c (fromIntegral numElems) elemsArr nullPtr+    newUint8Array <- jsstringcreatewithutf8cstring "new Uint8Array(this)"+    jsevaluatescript c newUint8Array a nullPtr 1 nullPtr+  send <- jsstringcreatewithutf8cstring "this[0]['send'](String['fromCharCode']['apply'](null, this[1]))"+  sendArgs <- toJSObject c [ws, bs']+  _ <- jsevaluatescript c send sendArgs nullPtr 1 nullPtr+  return ()+
src-ghc/Reflex/Dom/Xhr/Foreign.hs view
@@ -1,7 +1,8 @@-{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE QuasiQuotes, ForeignFunctionInterface #-}+ module Reflex.Dom.Xhr.Foreign where -import Control.Lens.Indexed+import Control.Monad import qualified Data.Text as T import Data.Text (Text) import System.Glib.FFI@@ -10,35 +11,40 @@ import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSObjectRef import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSStringRef import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSValueRef-import Graphics.UI.Gtk.WebKit.JavaScriptCore.WebFrame+import Reflex.Dom.Xhr.ResponseType+import Reflex.Dom.Xhr.Exception+import Control.Concurrent.MVar+import Control.Exception.Base+import Graphics.UI.Gtk.WebKit.Types hiding (Text) +import Reflex.Dom.Internal.Foreign++import Text.RawString.QQ+ data XMLHttpRequest    = XMLHttpRequest { xhrValue :: JSValueRef                     , xhrContext :: JSContextRef                     }    deriving (Eq, Ord) -toJSObject :: JSContextRef -> [Ptr OpaqueJSValue] -> IO JSObjectRef-toJSObject ctx args = do-  o <- jsobjectmake ctx nullPtr nullPtr-  iforM_ args $ \n a -> do-    prop <- jsstringcreatewithutf8cstring $ show n-    jsobjectsetproperty ctx o prop a 1 nullPtr-  return o--responseTextToText :: Maybe String -> Maybe Text-responseTextToText = fmap T.pack- stringToJSValue :: JSContextRef -> String -> IO JSValueRef stringToJSValue ctx s = jsvaluemakestring ctx =<< jsstringcreatewithutf8cstring s -toResponseType :: a -> a-toResponseType = id+fromResponseType :: XhrResponseType -> String+fromResponseType XhrResponseType_Default = ""+fromResponseType XhrResponseType_ArrayBuffer = "arraybuffer"+fromResponseType XhrResponseType_Blob = "blob"+fromResponseType XhrResponseType_Text = "text" +toResponseType :: String -> Maybe XhrResponseType+toResponseType "" = Just XhrResponseType_Default+toResponseType "arraybuffer" = Just XhrResponseType_ArrayBuffer+toResponseType "blob" = Just XhrResponseType_Blob+toResponseType "text" = Just XhrResponseType_Text+toResponseType _ = Nothing+ xmlHttpRequestNew :: WebView -> IO XMLHttpRequest-xmlHttpRequestNew wv = do-  wf <- webViewGetMainFrame wv-  jsContext <- webFrameGetGlobalContext wf+xmlHttpRequestNew wv = withWebViewContext wv $ \jsContext -> do   xhrScript <- jsstringcreatewithutf8cstring "new XMLHttpRequest()"   xhr' <- jsevaluatescript jsContext xhrScript nullPtr nullPtr 1 nullPtr   jsvalueprotect jsContext xhr'@@ -57,9 +63,6 @@   _ <- jsevaluatescript c script o nullPtr 1 nullPtr   return () -foreign import ccall "wrapper"-  wrapper :: JSObjectCallAsFunctionCallback' -> IO JSObjectCallAsFunctionCallback- xmlHttpRequestOnreadystatechange :: XMLHttpRequest -> IO () -> IO () xmlHttpRequestOnreadystatechange xhr userCallback = do   let c = xhrContext xhr@@ -80,38 +83,89 @@   d <- jsvaluetonumber c rs nullPtr   return $ truncate d -xmlHttpRequestGetResponseText :: XMLHttpRequest -> IO (Maybe String)-xmlHttpRequestGetResponseText xhr = do+xmlHttpRequestGetResponseType :: XMLHttpRequest -> IO (Maybe XhrResponseType)+xmlHttpRequestGetResponseType xhr = do+  script <- jsstringcreatewithutf8cstring "this.responseType"+  rt <- jsevaluatescript (xhrContext xhr) script (xhrValue xhr) nullPtr 1 nullPtr+  ms <- fromJSStringMaybe (xhrContext xhr) rt+  return $ join $ fmap toResponseType ms++xmlHttpRequestGetResponse :: XMLHttpRequest -> IO (Maybe XhrResponseBody)+xmlHttpRequestGetResponse xhr = do   let c = xhrContext xhr-  script <- jsstringcreatewithutf8cstring "this.responseText"+  mrt <- xmlHttpRequestGetResponseType xhr+  script <- jsstringcreatewithutf8cstring "this.response"   t <- jsevaluatescript c script (xhrValue xhr) nullPtr 1 nullPtr   isNull <- jsvalueisnull c t   case isNull of        True -> return Nothing-       False -> do-         j <- jsvaluetostringcopy c t nullPtr-         l <- jsstringgetmaximumutf8cstringsize j-         s <- allocaBytes (fromIntegral l) $ \ps -> do-                _ <- jsstringgetutf8cstring'_ j ps (fromIntegral l)-                peekCString ps-         return $ Just s+       False ->  case mrt of+         Just XhrResponseType_ArrayBuffer -> Just . XhrResponseBody_ArrayBuffer <$> bsFromArrayBuffer c t+         Just XhrResponseType_Blob -> Just . XhrResponseBody_Blob . Blob . castForeignPtr <$> newForeignPtr_ t+         Just XhrResponseType_Default -> fmap (XhrResponseBody_Default . T.pack) <$> fromJSStringMaybe c t+         Just XhrResponseType_Text -> fmap (XhrResponseBody_Text . T.pack) <$> fromJSStringMaybe c t+         _ -> return Nothing +xmlHttpRequestGetResponseText :: XMLHttpRequest -> IO (Maybe Text)+xmlHttpRequestGetResponseText xhr = do+  let c = xhrContext xhr+  script <- jsstringcreatewithutf8cstring "this.responseText"+  t <- jsevaluatescript c script (xhrValue xhr) nullPtr 1 nullPtr+  fmap (fmap T.pack) $ fromJSStringMaybe c t+ xmlHttpRequestSend :: XMLHttpRequest -> Maybe String -> IO () xmlHttpRequestSend xhr payload = do   let c = xhrContext xhr-  (o,s) <- case payload of-            Nothing -> do-              o <- toJSObject c [xhrValue xhr]-              s <- jsstringcreatewithutf8cstring "this[0].send();"-              return (o,s)-            Just payload' -> do-              d <- stringToJSValue c payload'-              o <- toJSObject c [xhrValue xhr, d]-              s <- jsstringcreatewithutf8cstring "this[0].send(this[1])"-              return (o,s)-  _ <- jsevaluatescript c s o nullPtr 1 nullPtr-  return ()-  +  result <- newEmptyMVar+  let wrapper' x = wrapper $ \_ _ _ _ _ _ -> putMVar result x >> jsvaluemakeundefined c+  bracket (wrapper' $ Just XhrException_Aborted) freeHaskellFunPtr $ \a -> do+    onAbort <- jsobjectmakefunctionwithcallback c nullPtr a+    bracket (wrapper' $ Just XhrException_Error) freeHaskellFunPtr $ \e -> do+      onError <- jsobjectmakefunctionwithcallback c nullPtr e+      bracket (wrapper' Nothing) freeHaskellFunPtr $ \l -> do+        onLoad <- jsobjectmakefunctionwithcallback c nullPtr l+        (o,s) <- case payload of+                  Nothing -> do+                    d <- jsvaluemakeundefined c+                    o <- toJSObject c [xhrValue xhr, d, onError, onAbort, onLoad]+                    s <- jsstringcreatewithutf8cstring send+                    return (o,s)+                  Just payload' -> do+                    d <- stringToJSValue c payload'+                    o <- toJSObject c [xhrValue xhr, d, onError, onAbort, onLoad]+                    s <- jsstringcreatewithutf8cstring send+                    return (o,s)+        _ <- jsevaluatescript c s o nullPtr 1 nullPtr+        takeMVar result >>= mapM_ throwIO+  where+    send = [r|+      (function (xhr, d, onError, onAbort, onLoad) {+          var clear;+          var error = function () {+              clear(); onError();+          };+          var abort = function () {+              clear(); onAbort();+          };+          var load = function () {+              clear(); onLoad();+          };+          clear = function () {+              xhr.removeEventListener('error', error);+              xhr.removeEventListener('abort', abort);+              xhr.removeEventListener('load', load);+          }+          xhr.addEventListener('error', error);+          xhr.addEventListener('abort', abort);+          xhr.addEventListener('load', load);+          if(d) {+            xhr.send(d);+          } else {+            xhr.send();+          }+      })(this[0], this[1], this[2], this[3], this[4])+    |]+ xmlHttpRequestSetRequestHeader :: XMLHttpRequest -> String -> String -> IO () xmlHttpRequestSetRequestHeader xhr header value = do   let c = xhrContext xhr@@ -139,7 +193,7 @@   d <- jsvaluetonumber c s nullPtr   return $ truncate d -xmlHttpRequestGetStatusText :: XMLHttpRequest -> IO String+xmlHttpRequestGetStatusText :: XMLHttpRequest -> IO Text xmlHttpRequestGetStatusText xhr = do   let c = xhrContext xhr   script <- jsstringcreatewithutf8cstring "this.statusText"@@ -149,4 +203,4 @@   s <- allocaBytes (fromIntegral l) $ \ps -> do          _ <- jsstringgetutf8cstring'_ j ps (fromIntegral l)          peekCString ps-  return s+  return $ T.pack s
src-ghcjs/Reflex/Dom/Internal/Foreign.hs view
@@ -1,9 +1,43 @@-module Reflex.Dom.Internal.Foreign (runWebGUI) where+{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI #-}+module Reflex.Dom.Internal.Foreign ( module Reflex.Dom.Internal.Foreign+                                   , runWebGUI+                                   ) where +import Control.Monad+import Data.ByteString (ByteString)+import Foreign+import Foreign.C import GHCJS.DOM import GHCJS.DOM.Types import GHCJS.Types-import Data.Function+import JavaScript.TypedArray.ArrayBuffer as JS+import qualified Data.ByteString as BS+import qualified GHCJS.Buffer as JS+import qualified GHCJS.Marshal.Pure as JS -instance Eq Node where-  (==) = eqRef `on` unNode+quitWebView :: WebView -> IO ()+quitWebView = error "quitWebView: unimplemented in GHCJS"++foreign import javascript unsafe "location['host']" getLocationHost_ :: IO JSString++getLocationHost :: FromJSString r => a -> IO r+getLocationHost _ = liftM fromJSString getLocationHost_++foreign import javascript unsafe "location['protocol']" getLocationProtocol_ :: IO JSString++getLocationProtocol :: FromJSString r => a -> IO r+getLocationProtocol _ = liftM fromJSString getLocationProtocol_++withWebViewContext :: a -> (a -> IO b) -> IO b+withWebViewContext a f = f a++foreign import javascript safe "new DataView($3,$1,$2)" js_dataView :: Int -> Int -> JSVal -> JSVal++foreign import javascript unsafe "new Uint8Array($1_1['buf'], $1_2, $2)['buffer']" extractByteArray :: Ptr CChar -> Int -> IO JSVal++bsToArrayBuffer :: a -> ByteString -> IO JSVal+bsToArrayBuffer _ bs = BS.useAsCString bs $ \cStr -> do+  extractByteArray cStr $ BS.length bs++bsFromArrayBuffer :: a -> JSVal -> IO ByteString+bsFromArrayBuffer _ ab = liftM (JS.toByteString 0 Nothing . JS.createFromArrayBuffer) $ JS.unsafeFreeze $ JS.pFromJSVal ab
+ src-ghcjs/Reflex/Dom/WebSocket/Foreign.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI, CPP #-}++module Reflex.Dom.WebSocket.Foreign where++import Prelude hiding (div, span, mapM, mapM_, concat, concatMap, all, sequence)++import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import GHCJS.Types+import GHCJS.DOM.WebSocket (message, open, closeEvent)+import qualified GHCJS.DOM.WebSocket as GD+import GHCJS.DOM.MessageEvent+import GHCJS.DOM.EventM (on)+import GHCJS.DOM.Types+import Control.Monad.IO.Class+import Control.Monad.Reader+import GHCJS.Buffer+import JavaScript.TypedArray.ArrayBuffer as JS+import GHCJS.Marshal.Pure++data JSWebSocket = JSWebSocket { unWebSocket :: WebSocket }++newWebSocket :: a -> String -> (ByteString -> IO ()) -> IO () -> IO () -> IO JSWebSocket+newWebSocket _ url onMessage onOpen onClose = do+  ws <- GD.newWebSocket url (Just [] :: Maybe [String])+  _ <- on ws open $ liftIO onOpen+  GD.setBinaryType ws "arraybuffer"+  _ <- on ws message $ do+    e <- ask+    d <- getData e+    ab <- liftIO $ unsafeFreeze $ pFromJSVal d+    liftIO $ onMessage $ toByteString 0 Nothing $ createFromArrayBuffer ab+  _ <- on ws closeEvent $ liftIO onClose+  return $ JSWebSocket ws++webSocketSend :: JSWebSocket -> ByteString -> IO ()+webSocketSend (JSWebSocket ws) bs = do+  let (b, off, len) = fromByteString bs+  ab <- ArrayBuffer <$> if BS.length bs == 0 --TODO: remove this logic when https://github.com/ghcjs/ghcjs-base/issues/49 is fixed+                        then jsval . getArrayBuffer <$> create 0+                        else return $ js_dataView off len $ jsval $ getArrayBuffer b+  GD.send ws $ Just ab++foreign import javascript safe "new DataView($3,$1,$2)" js_dataView :: Int -> Int -> JSVal -> JSVal
src-ghcjs/Reflex/Dom/Xhr/Foreign.hs view
@@ -1,396 +1,151 @@-{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI #-}+{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI, OverloadedStrings #-} -module Reflex.Dom.Xhr.Foreign where+module Reflex.Dom.Xhr.Foreign (+    XMLHttpRequest+  , XMLHttpRequestResponseType(..)+  , module Reflex.Dom.Xhr.Foreign+) where -import GHCJS.Types-import GHCJS.Foreign-import GHCJS.Marshal-import qualified Data.Text as T+import Prelude hiding (error) import Data.Text (Text)-import Data.Word import GHCJS.DOM.Types hiding (Text)-import Control.Applicative ((<$>))-import GHCJS.DOM.EventM import GHCJS.DOM-import Data.Function+import GHCJS.DOM.Enums+import GHCJS.DOM.XMLHttpRequest+import Data.Maybe (fromMaybe)+import GHCJS.DOM.EventTarget (dispatchEvent)+import GHCJS.DOM.EventM (EventM, on)+import Reflex.Dom.Internal.Foreign+import Reflex.Dom.Xhr.Exception+import Reflex.Dom.Xhr.ResponseType+import Control.Exception (catch, throwIO)  prepareWebView :: WebView -> IO () prepareWebView _ = return () -foreign import javascript unsafe "h$isInstanceOf $1 $2"-    typeInstanceIsA' :: JSRef a -> JSRef GType -> Bool--typeInstanceIsA :: JSRef a -> GType -> Bool-typeInstanceIsA o (GType t) = typeInstanceIsA' o t--castTo :: (GObjectClass obj, GObjectClass obj') => GType -> String-                                                -> (obj -> obj')-castTo gtype objTypeName obj =-  case toGObject obj of-    gobj@(GObject objRef)-      | typeInstanceIsA objRef gtype-                  -> unsafeCastGObject gobj-      | otherwise -> error $ "Cannot cast object to " ++ objTypeName---newtype XMLHttpRequest = XMLHttpRequest { unXMLHttpRequest :: JSRef XMLHttpRequest }--instance Eq XMLHttpRequest where-  (==) = eqRef `on` unXMLHttpRequest--instance ToJSRef XMLHttpRequest where-  toJSRef = return . unXMLHttpRequest-  {-# INLINE toJSRef #-}--instance FromJSRef XMLHttpRequest where-  fromJSRef = return . fmap XMLHttpRequest . maybeJSNull-  {-# INLINE fromJSRef #-}--class GObjectClass o => IsXMLHttpRequest o-toXMLHttpRequest :: IsXMLHttpRequest o => o -> XMLHttpRequest-toXMLHttpRequest = unsafeCastGObject . toGObject--instance IsXMLHttpRequest XMLHttpRequest-instance GObjectClass XMLHttpRequest where-  toGObject = GObject . castRef . unXMLHttpRequest-  unsafeCastGObject = XMLHttpRequest . castRef . unGObject--castToXMLHttpRequest :: GObjectClass obj => obj -> XMLHttpRequest-castToXMLHttpRequest = castTo gTypeXMLHttpRequest "XMLHttpRequest"--foreign import javascript unsafe "window[\"XMLHttpRequest\"]" gTypeXMLHttpRequest' :: JSRef GType-gTypeXMLHttpRequest :: GType-gTypeXMLHttpRequest = GType gTypeXMLHttpRequest'---newtype XMLHttpRequestUpload = XMLHttpRequestUpload { unXMLHttpRequestUpload :: JSRef XMLHttpRequestUpload }--instance Eq XMLHttpRequestUpload where-  (==) = eqRef `on` unXMLHttpRequestUpload--instance ToJSRef XMLHttpRequestUpload where-  toJSRef = return . unXMLHttpRequestUpload-  {-# INLINE toJSRef #-}--instance FromJSRef XMLHttpRequestUpload where-  fromJSRef = return . fmap XMLHttpRequestUpload . maybeJSNull-  {-# INLINE fromJSRef #-}--class GObjectClass o => IsXMLHttpRequestUpload o-toXMLHttpRequestUpload :: IsXMLHttpRequestUpload o => o -> XMLHttpRequestUpload-toXMLHttpRequestUpload = unsafeCastGObject . toGObject--instance IsXMLHttpRequestUpload XMLHttpRequestUpload-instance GObjectClass XMLHttpRequestUpload where-  toGObject = GObject . castRef . unXMLHttpRequestUpload-  unsafeCastGObject = XMLHttpRequestUpload . castRef . unGObject--castToXMLHttpRequestUpload :: GObjectClass obj => obj -> XMLHttpRequestUpload-castToXMLHttpRequestUpload = castTo gTypeXMLHttpRequestUpload "XMLHttpRequestUpload"--foreign import javascript unsafe "window[\"XMLHttpRequestUpload\"]" gTypeXMLHttpRequestUpload' :: JSRef GType-gTypeXMLHttpRequestUpload :: GType-gTypeXMLHttpRequestUpload = GType gTypeXMLHttpRequestUpload'--foreign import javascript unsafe "new XMLHttpRequest()"-        ghcjs_dom_xml_http_request_new ::-        IO (JSRef XMLHttpRequest)- xmlHttpRequestNew :: a -> IO XMLHttpRequest-xmlHttpRequestNew _ = XMLHttpRequest <$> ghcjs_dom_xml_http_request_new--foreign import javascript unsafe "$1[\"open\"]($2, $3, $4, $5, $6)"-        ghcjs_dom_xml_http_request_open ::-        JSRef XMLHttpRequest -> JSString -> JSString -> JSBool -> JSString -> JSString -> IO ()+xmlHttpRequestNew _ = newXMLHttpRequest  xmlHttpRequestOpen ::-                   (IsXMLHttpRequest self, ToJSString method, ToJSString url, ToJSString user, ToJSString password) =>-                     self -> method -> url -> Bool -> user -> password -> IO ()-xmlHttpRequestOpen self method url async user password-  = ghcjs_dom_xml_http_request_open-      (unXMLHttpRequest (toXMLHttpRequest self))-      (toJSString method)-      (toJSString url)-      (toJSBool async)-      (toJSString user)-      (toJSString password)--foreign import javascript unsafe "($2===null)?$1[\"send\"]():$1[\"send\"]($2)"-        ghcjs_dom_xml_http_request_send ::-        JSRef XMLHttpRequest -> JSString -> IO ()--xmlHttpRequestSend ::-                   (IsXMLHttpRequest self, ToJSString payload) =>-                     self -> Maybe payload -> IO ()-xmlHttpRequestSend self payload-  = ghcjs_dom_xml_http_request_send-      (unXMLHttpRequest (toXMLHttpRequest self))-      (case payload of-            Just p -> toJSString p-            Nothing -> jsNull)---foreign import javascript unsafe "$1[\"setRequestHeader\"]($2, $3)"-        ghcjs_dom_xml_http_request_set_request_header ::-        JSRef XMLHttpRequest -> JSString -> JSString -> IO ()--xmlHttpRequestSetRequestHeader ::-                               (IsXMLHttpRequest self, ToJSString header, ToJSString value) =>-                                 self -> header -> value -> IO ()-xmlHttpRequestSetRequestHeader self header value-  = ghcjs_dom_xml_http_request_set_request_header-      (unXMLHttpRequest (toXMLHttpRequest self))-      (toJSString header)-      (toJSString value)--foreign import javascript unsafe "$1[\"abort\"]()"-        ghcjs_dom_xml_http_request_abort :: JSRef XMLHttpRequest -> IO ()--xmlHttpRequestAbort :: (IsXMLHttpRequest self) => self -> IO ()-xmlHttpRequestAbort self-  = ghcjs_dom_xml_http_request_abort-      (unXMLHttpRequest (toXMLHttpRequest self))--foreign import javascript unsafe "$1[\"getAllResponseHeaders\"]()"-        ghcjs_dom_xml_http_request_get_all_response_headers ::-        JSRef XMLHttpRequest -> IO JSString--xmlHttpRequestGetAllResponseHeaders ::-                                    (IsXMLHttpRequest self, FromJSString result) =>-                                      self -> IO result-xmlHttpRequestGetAllResponseHeaders self-  = fromJSString <$>-      (ghcjs_dom_xml_http_request_get_all_response_headers-         (unXMLHttpRequest (toXMLHttpRequest self)))--foreign import javascript unsafe "$1[\"getResponseHeader\"]($2)"-        ghcjs_dom_xml_http_request_get_response_header ::-        JSRef XMLHttpRequest -> JSString -> IO JSString--xmlHttpRequestGetResponseHeader ::-                                (IsXMLHttpRequest self, ToJSString header, FromJSString result) =>-                                  self -> header -> IO result-xmlHttpRequestGetResponseHeader self header-  = fromJSString <$>-      (ghcjs_dom_xml_http_request_get_response_header-         (unXMLHttpRequest (toXMLHttpRequest self))-         (toJSString header))--foreign import javascript unsafe "$1[\"overrideMimeType\"]($2)"-        ghcjs_dom_xml_http_request_override_mime_type ::-        JSRef XMLHttpRequest -> JSString -> IO ()--xmlHttpRequestOverrideMimeType ::-                               (IsXMLHttpRequest self, ToJSString override) =>-                                 self -> override -> IO ()-xmlHttpRequestOverrideMimeType self override-  = ghcjs_dom_xml_http_request_override_mime_type-      (unXMLHttpRequest (toXMLHttpRequest self))-      (toJSString override)--foreign import javascript unsafe-        "($1[\"dispatchEvent\"]($2) ? 1 : 0)"-        ghcjs_dom_xml_http_request_dispatch_event ::-        JSRef XMLHttpRequest -> JSRef Event -> IO Bool--xmlHttpRequestDispatchEvent ::-                            (IsXMLHttpRequest self, IsEvent evt) =>-                              self -> Maybe evt -> IO Bool-xmlHttpRequestDispatchEvent self evt-  = ghcjs_dom_xml_http_request_dispatch_event-      (unXMLHttpRequest (toXMLHttpRequest self))-      (maybe jsNull (unEvent . toEvent) evt)--cUNSENT :: Integer-cUNSENT = 0--cOPENED :: Integer-cOPENED = 1--cHEADERS_RECEIVED :: Integer-cHEADERS_RECEIVED = 2--cLOADING :: Integer-cLOADING = 3--cDONE :: Integer-cDONE = 4--xmlHttpRequestOnabort ::-                      (IsXMLHttpRequest self) => Signal self (EventM UIEvent self ())-xmlHttpRequestOnabort = (connect "abort")--xmlHttpRequestOnerror ::-                      (IsXMLHttpRequest self) => Signal self (EventM UIEvent self ())-xmlHttpRequestOnerror = (connect "error")--xmlHttpRequestOnload ::-                     (IsXMLHttpRequest self) => Signal self (EventM UIEvent self ())-xmlHttpRequestOnload = (connect "load")--xmlHttpRequestOnloadend ::-                        (IsXMLHttpRequest self) => Signal self (EventM UIEvent self ())-xmlHttpRequestOnloadend = (connect "loadend")+                   (ToJSString method, ToJSString url, ToJSString user, ToJSString password) =>+                     XMLHttpRequest -> method -> url -> Bool -> user -> password -> IO ()+xmlHttpRequestOpen = open -xmlHttpRequestOnloadstart ::-                          (IsXMLHttpRequest self) => Signal self (EventM UIEvent self ())-xmlHttpRequestOnloadstart = (connect "loadstart")+convertException :: XHRError -> XhrException+convertException e = case e of+  XHRError -> XhrException_Error+  XHRAborted -> XhrException_Aborted -xmlHttpRequestOnprogress ::-                         (IsXMLHttpRequest self) => Signal self (EventM UIEvent self ())-xmlHttpRequestOnprogress = (connect "progress")+-- This used to be a non blocking call, but now it uses an interruptible ffi+xmlHttpRequestSend :: ToJSString payload => XMLHttpRequest -> Maybe payload -> IO ()+xmlHttpRequestSend self p = (maybe (send self) (sendString self) p) `catch` (throwIO . convertException) -xmlHttpRequestOntimeout ::-                        (IsXMLHttpRequest self) => Signal self (EventM UIEvent self ())-xmlHttpRequestOntimeout = (connect "timeout")+xmlHttpRequestSetRequestHeader :: (ToJSString header, ToJSString value)+                               => XMLHttpRequest -> header -> value -> IO ()+xmlHttpRequestSetRequestHeader = setRequestHeader -xmlHttpRequestOnreadystatechange ::-                                 (IsXMLHttpRequest self) => Signal self (EventM UIEvent self ())-xmlHttpRequestOnreadystatechange = (connect "readystatechange")+xmlHttpRequestAbort :: XMLHttpRequest -> IO ()+xmlHttpRequestAbort = abort -foreign import javascript unsafe "$1[\"timeout\"] = $2;"-        ghcjs_dom_xml_http_request_set_timeout ::-        JSRef XMLHttpRequest -> Word -> IO ()+xmlHttpRequestGetAllResponseHeaders :: XMLHttpRequest -> IO Text+xmlHttpRequestGetAllResponseHeaders self = fromMaybe "" <$> getAllResponseHeaders self -xmlHttpRequestSetTimeout ::-                         (IsXMLHttpRequest self) => self -> Word -> IO ()-xmlHttpRequestSetTimeout self val-  = ghcjs_dom_xml_http_request_set_timeout-      (unXMLHttpRequest (toXMLHttpRequest self))-      val+xmlHttpRequestGetResponseHeader :: (ToJSString header)+                                => XMLHttpRequest -> header -> IO Text+xmlHttpRequestGetResponseHeader self header = fromMaybe "" <$> getResponseHeader self header -foreign import javascript unsafe "$1[\"timeout\"]"-        ghcjs_dom_xml_http_request_get_timeout ::-        JSRef XMLHttpRequest -> IO Word+xmlHttpRequestOverrideMimeType :: ToJSString override => XMLHttpRequest -> override -> IO ()+xmlHttpRequestOverrideMimeType = overrideMimeType -xmlHttpRequestGetTimeout ::-                         (IsXMLHttpRequest self) => self -> IO Word-xmlHttpRequestGetTimeout self-  = ghcjs_dom_xml_http_request_get_timeout-      (unXMLHttpRequest (toXMLHttpRequest self))+xmlHttpRequestDispatchEvent :: IsEvent evt => XMLHttpRequest -> Maybe evt -> IO Bool+xmlHttpRequestDispatchEvent = dispatchEvent -foreign import javascript unsafe "$1[\"readyState\"]"-        ghcjs_dom_xml_http_request_get_ready_state ::-        JSRef XMLHttpRequest -> IO Word+xmlHttpRequestOnabort :: XMLHttpRequest -> EventM XMLHttpRequest XMLHttpRequestProgressEvent () -> IO (IO ())+xmlHttpRequestOnabort = (`on` abortEvent) -xmlHttpRequestGetReadyState ::-                            (IsXMLHttpRequest self) => self -> IO Word-xmlHttpRequestGetReadyState self-  = ghcjs_dom_xml_http_request_get_ready_state-      (unXMLHttpRequest (toXMLHttpRequest self))+xmlHttpRequestOnerror :: XMLHttpRequest -> EventM XMLHttpRequest XMLHttpRequestProgressEvent () -> IO (IO ())+xmlHttpRequestOnerror = (`on` error) -foreign import javascript unsafe "$1[\"withCredentials\"] = $2;"-        ghcjs_dom_xml_http_request_set_with_credentials ::-        JSRef XMLHttpRequest -> Bool -> IO ()+xmlHttpRequestOnload :: XMLHttpRequest -> EventM XMLHttpRequest XMLHttpRequestProgressEvent () -> IO (IO ())+xmlHttpRequestOnload = (`on` load) -xmlHttpRequestSetWithCredentials ::-                                 (IsXMLHttpRequest self) => self -> Bool -> IO ()-xmlHttpRequestSetWithCredentials self val-  = ghcjs_dom_xml_http_request_set_with_credentials-      (unXMLHttpRequest (toXMLHttpRequest self))-      val+xmlHttpRequestOnloadend :: XMLHttpRequest -> EventM XMLHttpRequest ProgressEvent () -> IO (IO ())+xmlHttpRequestOnloadend = (`on` loadEnd) -foreign import javascript unsafe-        "($1[\"withCredentials\"] ? 1 : 0)"-        ghcjs_dom_xml_http_request_get_with_credentials ::-        JSRef XMLHttpRequest -> IO Bool+xmlHttpRequestOnloadstart :: XMLHttpRequest -> EventM XMLHttpRequest ProgressEvent () -> IO (IO ())+xmlHttpRequestOnloadstart = (`on` loadStart) -xmlHttpRequestGetWithCredentials ::-                                 (IsXMLHttpRequest self) => self -> IO Bool-xmlHttpRequestGetWithCredentials self-  = ghcjs_dom_xml_http_request_get_with_credentials-      (unXMLHttpRequest (toXMLHttpRequest self))+xmlHttpRequestOnprogress :: XMLHttpRequest -> EventM XMLHttpRequest XMLHttpRequestProgressEvent () -> IO (IO ())+xmlHttpRequestOnprogress = (`on` progress) -foreign import javascript unsafe "$1[\"upload\"]"-        ghcjs_dom_xml_http_request_get_upload ::-        JSRef XMLHttpRequest -> IO (JSRef XMLHttpRequestUpload)+xmlHttpRequestOntimeout :: XMLHttpRequest -> EventM XMLHttpRequest ProgressEvent () -> IO (IO ())+xmlHttpRequestOntimeout = (`on` timeout) -xmlHttpRequestGetUpload ::-                        (IsXMLHttpRequest self) => self -> IO (Maybe XMLHttpRequestUpload)-xmlHttpRequestGetUpload self-  = fmap XMLHttpRequestUpload . maybeJSNull <$>-      (ghcjs_dom_xml_http_request_get_upload-         (unXMLHttpRequest (toXMLHttpRequest self)))+xmlHttpRequestOnreadystatechange :: XMLHttpRequest -> EventM XMLHttpRequest Event () -> IO (IO ())+xmlHttpRequestOnreadystatechange = (`on` readyStateChange) -foreign import javascript unsafe "$1[\"responseText\"]"-        ghcjs_dom_xml_http_request_get_response_text ::-        JSRef XMLHttpRequest -> IO JSString+xmlHttpRequestSetTimeout :: XMLHttpRequest -> Word -> IO ()+xmlHttpRequestSetTimeout = setTimeout -xmlHttpRequestGetResponseText ::-                             (IsXMLHttpRequest self, FromJSString result) => self -> IO (Maybe result)-xmlHttpRequestGetResponseText self-  = fmap fromJSString . maybeJSNull <$>-      (ghcjs_dom_xml_http_request_get_response_text-         (unXMLHttpRequest (toXMLHttpRequest self)))+xmlHttpRequestGetTimeout :: XMLHttpRequest -> IO Word+xmlHttpRequestGetTimeout = getTimeout -responseTextToText :: (Maybe JSString) -> Maybe Text-responseTextToText r = fmap (T.pack . fromJSString) r+xmlHttpRequestGetReadyState :: XMLHttpRequest -> IO Word+xmlHttpRequestGetReadyState = getReadyState -foreign import javascript unsafe "$1[\"responseXML\"]"-        ghcjs_dom_xml_http_request_get_response_xml ::-        JSRef XMLHttpRequest -> IO (JSRef Document)+xmlHttpRequestSetWithCredentials :: XMLHttpRequest -> Bool -> IO ()+xmlHttpRequestSetWithCredentials = setWithCredentials -xmlHttpRequestGetResponseXML ::-                             (IsXMLHttpRequest self) => self -> IO (Maybe Document)-xmlHttpRequestGetResponseXML self-  = fmap Document . maybeJSNull <$>-      (ghcjs_dom_xml_http_request_get_response_xml-         (unXMLHttpRequest (toXMLHttpRequest self)))+xmlHttpRequestGetWithCredentials :: XMLHttpRequest -> IO Bool+xmlHttpRequestGetWithCredentials = getWithCredentials -foreign import javascript unsafe "$1[\"responseType\"] = $2;"-        ghcjs_dom_xml_http_request_set_response_type ::-        JSRef XMLHttpRequest -> JSString -> IO ()+xmlHttpRequestGetUpload :: XMLHttpRequest -> IO (Maybe XMLHttpRequestUpload)+xmlHttpRequestGetUpload = getUpload -xmlHttpRequestSetResponseType ::-                              (IsXMLHttpRequest self, ToJSString val) => self -> val -> IO ()-xmlHttpRequestSetResponseType self val-  = ghcjs_dom_xml_http_request_set_response_type-      (unXMLHttpRequest (toXMLHttpRequest self))-      (toJSString val)+xmlHttpRequestGetResponseText :: FromJSString result => XMLHttpRequest -> IO (Maybe result)+xmlHttpRequestGetResponseText = getResponseText -toResponseType :: (ToJSString a) => a -> JSString-toResponseType = toJSString+xmlHttpRequestGetResponseXML :: XMLHttpRequest -> IO (Maybe Document)+xmlHttpRequestGetResponseXML = getResponseXML -foreign import javascript unsafe "$1[\"responseType\"]"-        ghcjs_dom_xml_http_request_get_response_type ::-        JSRef XMLHttpRequest -> IO JSString+xmlHttpRequestSetResponseType :: XMLHttpRequest -> XMLHttpRequestResponseType -> IO ()+xmlHttpRequestSetResponseType = setResponseType -xmlHttpRequestGetResponseType ::-                              (IsXMLHttpRequest self, FromJSString result) => self -> IO result-xmlHttpRequestGetResponseType self-  = fromJSString <$>-      (ghcjs_dom_xml_http_request_get_response_type-         (unXMLHttpRequest (toXMLHttpRequest self)))+fromResponseType :: XhrResponseType -> XMLHttpRequestResponseType+fromResponseType XhrResponseType_Default = XMLHttpRequestResponseType+fromResponseType XhrResponseType_ArrayBuffer = XMLHttpRequestResponseTypeArraybuffer+fromResponseType XhrResponseType_Blob = XMLHttpRequestResponseTypeBlob+fromResponseType XhrResponseType_Text = XMLHttpRequestResponseTypeText -foreign import javascript unsafe "$1[\"status\"]"-        ghcjs_dom_xml_http_request_get_status ::-        JSRef XMLHttpRequest -> IO Word+toResponseType :: XMLHttpRequestResponseType -> Maybe XhrResponseType+toResponseType XMLHttpRequestResponseType = Just XhrResponseType_Default+toResponseType XMLHttpRequestResponseTypeArraybuffer = Just XhrResponseType_ArrayBuffer+toResponseType XMLHttpRequestResponseTypeBlob = Just XhrResponseType_Blob+toResponseType XMLHttpRequestResponseTypeText = Just XhrResponseType_Text+toResponseType _ = Nothing -xmlHttpRequestGetStatus ::-                        (IsXMLHttpRequest self) => self -> IO Word-xmlHttpRequestGetStatus self-  = ghcjs_dom_xml_http_request_get_status-      (unXMLHttpRequest (toXMLHttpRequest self))+xmlHttpRequestGetResponseType :: XMLHttpRequest -> IO (Maybe XhrResponseType)+xmlHttpRequestGetResponseType = fmap toResponseType . getResponseType -foreign import javascript unsafe "$1[\"statusText\"]"-        ghcjs_dom_xml_http_request_get_status_text ::-        JSRef XMLHttpRequest -> IO JSString+xmlHttpRequestGetStatus :: XMLHttpRequest -> IO Word+xmlHttpRequestGetStatus = getStatus -xmlHttpRequestGetStatusText ::-                            (IsXMLHttpRequest self, FromJSString result) => self -> IO result-xmlHttpRequestGetStatusText self-  = fromJSString <$>-      (ghcjs_dom_xml_http_request_get_status_text-         (unXMLHttpRequest (toXMLHttpRequest self)))+xmlHttpRequestGetStatusText :: FromJSString result => XMLHttpRequest -> IO result+xmlHttpRequestGetStatusText = getStatusText -foreign import javascript unsafe "$1[\"responseURL\"]"-        ghcjs_dom_xml_http_request_get_response_url ::-        JSRef XMLHttpRequest -> IO JSString+xmlHttpRequestGetResponseURL :: FromJSString result => XMLHttpRequest -> IO result+xmlHttpRequestGetResponseURL = getResponseURL -xmlHttpRequestGetResponseURL ::-                             (IsXMLHttpRequest self, FromJSString result) => self -> IO result-xmlHttpRequestGetResponseURL self-  = fromJSString <$>-      (ghcjs_dom_xml_http_request_get_response_url-         (unXMLHttpRequest (toXMLHttpRequest self)))+xmlHttpRequestGetResponse :: XMLHttpRequest -> IO (Maybe XhrResponseBody)+xmlHttpRequestGetResponse xhr = do+  mr <- getResponse xhr+  rt <- xmlHttpRequestGetResponseType xhr+  case rt of+       Just XhrResponseType_Blob -> return $ fmap (XhrResponseBody_Blob . castToBlob) mr+       Just XhrResponseType_Text -> fmap (Just . XhrResponseBody_Text) $ xmlHttpRequestGetStatusText xhr+       Just XhrResponseType_Default -> fmap (Just . XhrResponseBody_Text) $ xmlHttpRequestGetStatusText xhr+       Just XhrResponseType_ArrayBuffer -> case (fmap unGObject mr) of+         Nothing -> return Nothing+         Just ptr -> fmap (Just . XhrResponseBody_ArrayBuffer) $ bsFromArrayBuffer ptr ptr+       _ -> return Nothing
src/Reflex/Dom.hs view
@@ -4,6 +4,8 @@                   , module Reflex.Dom.Widget                   , module Reflex.Dom.Xhr                   , module Reflex.Dom.Time+                  , module Reflex.Dom.WebSocket+                  , module Reflex.Dom.Location                   ) where  import Reflex@@ -12,3 +14,5 @@ import Reflex.Dom.Widget import Reflex.Dom.Xhr import Reflex.Dom.Time+import Reflex.Dom.WebSocket+import Reflex.Dom.Location
src/Reflex/Dom/Class.hs view
@@ -77,13 +77,13 @@  class (MonadRef h, Ref h ~ Ref m, MonadRef m) => HasPostGui t h m | m -> t h where   askPostGui :: m (h () -> IO ())-  askRunWithActions :: m ([DSum (EventTrigger t)] -> h ())+  askRunWithActions :: m ([DSum (EventTrigger t) Identity] -> h ())  runFrameWithTriggerRef :: (HasPostGui t h m, MonadRef m, MonadIO m) => Ref m (Maybe (EventTrigger t a)) -> a -> m () runFrameWithTriggerRef r a = do   postGui <- askPostGui   runWithActions <- askRunWithActions-  liftIO . postGui $ mapM_ (\t -> runWithActions [t :=> a]) =<< readRef r  +  liftIO . postGui $ mapM_ (\t -> runWithActions [t :=> Identity a]) =<< readRef r    instance HasPostGui t h m => HasPostGui t h (ReaderT r m) where   askPostGui = lift askPostGui@@ -126,7 +126,7 @@   addVoidAction $ ffor e $ \o -> do     postGui <- askPostGui     runWithActions <- askRunWithActions-    o $ \a -> postGui $ mapM_ (\t -> runWithActions [t :=> a]) =<< readRef reResultTrigger+    o $ \a -> postGui $ mapM_ (\t -> runWithActions [t :=> Identity a]) =<< readRef reResultTrigger   return eResult  getPostBuild :: MonadWidget t m => m (Event t ())
src/Reflex/Dom/Internal.hs view
@@ -9,7 +9,7 @@ import GHCJS.DOM hiding (runWebGUI) import GHCJS.DOM.Types hiding (Widget, unWidget, Event) import GHCJS.DOM.Node-import GHCJS.DOM.HTMLElement+import GHCJS.DOM.Element import GHCJS.DOM.Document import Reflex.Class import Reflex.Host.Class@@ -33,7 +33,7 @@ data GuiEnv t h    = GuiEnv { _guiEnvDocument :: !HTMLDocument             , _guiEnvPostGui :: !(h () -> IO ())-            , _guiEnvRunWithActions :: !([DSum (EventTrigger t)] -> h ())+            , _guiEnvRunWithActions :: !([DSum (EventTrigger t) Identity] -> h ())             , _guiEnvWebView :: !WebView             } @@ -162,6 +162,10 @@ --  runWidget :: (Monad m, IsNode n, Reflex t) => n -> Widget t m a -> m (a, Event t (m ()))   getRunWidget = return runWidget +getQuitWidget :: MonadWidget t m => m (WidgetHost m ())+getQuitWidget = return $ do wv <- askWebView+                            liftIO $ quitWebView wv+ runWidget :: (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)) ())) runWidget rootElement w = do   (result, WidgetState postBuild voidActions) <- runStateT (runReaderT (unWidget w) (WidgetEnv $ toNode rootElement)) (WidgetState (return ()) [])@@ -179,23 +183,23 @@ mainWidget :: Widget Spider (Gui Spider (WithWebView SpiderHost) (HostFrame Spider)) () -> IO () mainWidget w = runWebGUI $ \webView -> do   Just doc <- liftM (fmap castToHTMLDocument) $ webViewGetDomDocument webView-  Just body <- documentGetBody doc+  Just body <- getBody doc   attachWidget body webView w  mainWidgetWithHead :: Widget Spider (Gui Spider (WithWebView SpiderHost) (HostFrame Spider)) () -> Widget Spider (Gui Spider (WithWebView SpiderHost) (HostFrame Spider)) () -> IO () mainWidgetWithHead h b = runWebGUI $ \webView -> do   Just doc <- liftM (fmap castToHTMLDocument) $ webViewGetDomDocument webView-  Just headElement <- liftM (fmap castToHTMLElement) $ documentGetHead doc+  Just headElement <- liftM (fmap castToHTMLElement) $ getHead doc   attachWidget headElement webView h-  Just body <- documentGetBody doc+  Just body <- getBody doc   attachWidget body webView b  mainWidgetWithCss :: ByteString -> Widget Spider (Gui Spider (WithWebView SpiderHost) (HostFrame Spider)) () -> IO () mainWidgetWithCss css w = runWebGUI $ \webView -> do   Just doc <- liftM (fmap castToHTMLDocument) $ webViewGetDomDocument webView-  Just headElement <- liftM (fmap castToHTMLElement) $ documentGetHead doc-  htmlElementSetInnerHTML headElement $ "<style>" <> T.unpack (decodeUtf8 css) <> "</style>" --TODO: Fix this-  Just body <- documentGetBody doc+  Just headElement <- liftM (fmap castToHTMLElement) $ getHead doc+  setInnerHTML headElement . Just $ "<style>" <> T.unpack (decodeUtf8 css) <> "</style>" --TODO: Fix this+  Just body <- getBody doc   attachWidget body webView w  newtype WithWebView m a = WithWebView { unWithWebView :: ReaderT WebView m a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadException, MonadAsyncException)@@ -245,20 +249,20 @@  attachWidget :: (IsHTMLElement e) => e -> WebView -> Widget Spider (Gui Spider (WithWebView SpiderHost) (HostFrame Spider)) a -> IO a attachWidget 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-  Just doc <- liftM (fmap castToHTMLDocument) $ liftIO $ nodeGetOwnerDocument rootElement+  Just doc <- liftM (fmap castToHTMLDocument) $ getOwnerDocument rootElement   frames <- liftIO newChan   rec let guiEnv = GuiEnv doc (writeChan frames . runSpiderHost . flip runWithWebView wv) runWithActions wv :: GuiEnv Spider (WithWebView SpiderHost)           runWithActions dm = do             voidActionNeeded <- fireEventsAndRead dm $ do               sequence =<< readEvent voidActionHandle             runHostFrame $ runGui (sequence_ voidActionNeeded) guiEnv-      Just df <- liftIO $ documentCreateDocumentFragment doc+      Just df <- createDocumentFragment doc       (result, voidAction) <- runHostFrame $ flip runGui guiEnv $ do         (r, postBuild, va) <- runWidget df w         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         return (r, va)-      liftIO $ htmlElementSetInnerHTML rootElement ""-      _ <- liftIO $ nodeAppendChild rootElement $ Just df+      setInnerHTML rootElement $ Just ""+      _ <- appendChild rootElement $ Just df       voidActionHandle <- subscribeEvent voidAction --TODO: Should be unnecessary   --postGUISync seems to leak memory on GHC (unknown on GHCJS)   _ <- liftIO $ forkIO $ forever $ postGUISync =<< readChan frames -- postGUISync is necessary to prevent segfaults in GTK, which is not thread-safe
+ src/Reflex/Dom/Location.hs view
@@ -0,0 +1,3 @@+module Reflex.Dom.Location (getLocationHost, getLocationProtocol) where++import Reflex.Dom.Internal.Foreign
src/Reflex/Dom/Time.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-} module Reflex.Dom.Time where  import Reflex@@ -39,13 +40,34 @@     -> m (Event t TickInfo) tickLossyFrom dt t0 e = performEventAsync $ fmap callAtNextInterval e   where callAtNextInterval _ cb = void $ liftIO $ forkIO $ forever $ do-          t <- getCurrentTime-          let offset = t `diffUTCTime` t0-              (n, alreadyElapsed) = offset `divMod'` dt-          threadDelay $ ceiling $ (dt - alreadyElapsed) * 1000000-          cb $ TickInfo t n alreadyElapsed+          tick <- getCurrentTick dt t0+          threadDelay $ ceiling $ (dt - _tickInfo_alreadyElapsed tick) * 1000000+          cb tick +clockLossy :: MonadWidget t m => NominalDiffTime -> UTCTime -> m (Dynamic t TickInfo)+clockLossy dt t0 = do+  initial <- liftIO $ getCurrentTick dt t0+  e <- tickLossy dt t0+  holdDyn initial e++getCurrentTick :: NominalDiffTime -> UTCTime -> IO TickInfo+getCurrentTick dt t0 = do+  t <- getCurrentTime+  let offset = t `diffUTCTime` t0+      (n, alreadyElapsed) = offset `divMod'` dt+  return $ TickInfo t n alreadyElapsed++-- | Delay an Event's occurrences by a given amount in seconds. delay :: MonadWidget t m => NominalDiffTime -> Event t a -> m (Event t a) delay dt e = performEventAsync $ ffor e $ \a cb -> liftIO $ void $ forkIO $ do   threadDelay $ ceiling $ dt * 1000000   cb a++-- | Block occurrences of an Event until the given number of seconds elapses without+--   the Event firing, at which point the last occurrence of the Event will fire.+debounce :: MonadWidget t m => NominalDiffTime -> Event t a -> m (Event t a)+debounce dt e = do+  n :: Dynamic t Integer <- count e+  let tagged = attachDynWith (,) n e+  delayed <- delay dt tagged+  return $ attachWithMaybe (\n' (t, v) -> if n' == t then Just v else Nothing) (current n) delayed
+ src/Reflex/Dom/WebSocket.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI, CPP, TemplateHaskell, NoMonomorphismRestriction, EmptyDataDecls, RankNTypes, GADTs, RecursiveDo, ScopedTypeVariables, FlexibleInstances, MultiParamTypeClasses, TypeFamilies, FlexibleContexts, DeriveDataTypeable, GeneralizedNewtypeDeriving, StandaloneDeriving, ConstraintKinds, UndecidableInstances, PolyKinds, AllowAmbiguousTypes #-}++module Reflex.Dom.WebSocket where++import Prelude hiding (div, span, mapM, mapM_, concat, concatMap, all, sequence)++import Reflex+import Reflex.Host.Class+import Reflex.Dom.Class+import Reflex.Dom.WebSocket.Foreign++import Control.Concurrent+import Control.Lens+import Control.Monad hiding (forM, forM_, mapM, mapM_, sequence)+import Control.Monad.IO.Class+import Control.Monad.Ref+import Control.Monad.State+import Data.ByteString (ByteString)+import Data.Default+import Data.Dependent.Map (DSum (..))+import Data.IORef++data WebSocketConfig t+   = WebSocketConfig { _webSocketConfig_send :: Event t [ByteString]+                     }++instance Reflex t => Default (WebSocketConfig t) where+  def = WebSocketConfig never++data WebSocket t+   = WebSocket { _webSocket_recv :: Event t ByteString+               , _webSocket_open :: Event t ()+               }++webSocket :: forall t m. (HasWebView m, MonadWidget t m) => String -> WebSocketConfig t -> m (WebSocket t)+webSocket url config = do+  wv <- askWebView+  postGui <- askPostGui+  runWithActions <- askRunWithActions+  (eRecv, eRecvTriggerRef) <- newEventWithTriggerRef+  currentSocketRef <- liftIO $ newIORef Nothing+  --TODO: Disconnect if value no longer needed+  (eOpen, eOpenTriggerRef) <- newEventWithTriggerRef+  let onMessage :: ByteString -> IO ()+      onMessage m = postGui $ do+        mt <- readRef eRecvTriggerRef+        forM_ mt $ \t -> runWithActions [t :=> Identity m]+      onOpen = postGui $ do+        mt <- readRef eOpenTriggerRef+        forM_ mt $ \t -> runWithActions [t :=> Identity ()]+      start = do+        ws <- liftIO $ newWebSocket wv url onMessage onOpen $ do+          void $ forkIO $ do --TODO: Is the fork necessary, or do event handlers run in their own threads automatically?+            liftIO $ writeIORef currentSocketRef Nothing+            liftIO $ threadDelay 1000000+            start+        liftIO $ writeIORef currentSocketRef $ Just ws+        return ()+  schedulePostBuild $ liftIO start+  performEvent_ $ ffor (_webSocketConfig_send config) $ \payloads -> forM_ payloads $ \payload -> do+    mws <- liftIO $ readIORef currentSocketRef+    case mws of+      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?+      Just ws -> do+        liftIO $ webSocketSend ws payload+  return $ WebSocket eRecv eOpen++makeLensesWith (lensRules & simpleLenses .~ True) ''WebSocketConfig
src/Reflex/Dom/Widget.hs view
@@ -1,8 +1,10 @@ module Reflex.Dom.Widget ( module Reflex.Dom.Widget.Basic                          , module Reflex.Dom.Widget.Input                          , module Reflex.Dom.Widget.Lazy+                         , module Reflex.Dom.Widget.Resize                          ) where  import Reflex.Dom.Widget.Basic import Reflex.Dom.Widget.Input import Reflex.Dom.Widget.Lazy+import Reflex.Dom.Widget.Resize
src/Reflex/Dom/Widget/Basic.hs view
@@ -21,12 +21,12 @@ import Control.Monad.State hiding (state, mapM, mapM_, forM, forM_, sequence, sequence_) import GHCJS.DOM.Node import GHCJS.DOM.UIEvent-import GHCJS.DOM.EventM (event, EventM)+import GHCJS.DOM.EventM (on, event, EventM, stopPropagation) import GHCJS.DOM.Document-import GHCJS.DOM.Element-import GHCJS.DOM.HTMLElement-import GHCJS.DOM.Types hiding (Widget (..), unWidget, Event)-import GHCJS.DOM.NamedNodeMap+import GHCJS.DOM.Element as E+import GHCJS.DOM.Types hiding (Event)+import qualified GHCJS.DOM.Types as DOM (Event)+import GHCJS.DOM.NamedNodeMap as NNM import Control.Lens hiding (element, children) import Data.These import Data.Align@@ -34,11 +34,25 @@ import Data.GADT.Compare.TH import Data.Bitraversable import GHCJS.DOM.MouseEvent+import Data.IORef+import Data.Default  type AttributeMap = Map String String +data ElConfig attrs+  = ElConfig { _elConfig_namespace :: Maybe String+             , _elConfig_attributes :: attrs+             }++makeLenses ''ElConfig++instance (attrs ~ Map String String) => Default (ElConfig attrs) where+  def = ElConfig { _elConfig_namespace = Nothing+                 , _elConfig_attributes = Map.empty+                 }+ data El t-  = El { _el_element :: HTMLElement+  = El { _el_element :: Element        , _el_events :: EventSelector t (WrapArg EventResult EventName)        } @@ -46,41 +60,49 @@   addAttributes :: IsElement e => a -> e -> m ()  instance MonadIO m => Attributes m AttributeMap where-  addAttributes curAttrs e = liftIO $ imapM_ (elementSetAttribute e) curAttrs+  addAttributes curAttrs e = imapM_ (setAttribute e) curAttrs  instance MonadWidget t m => Attributes m (Dynamic t AttributeMap) where   addAttributes attrs e = do     schedulePostBuild $ do       curAttrs <- sample $ current attrs-      liftIO $ imapM_ (elementSetAttribute e) curAttrs+      imapM_ (setAttribute e) curAttrs     addVoidAction $ flip fmap (updated attrs) $ \newAttrs -> liftIO $ do-      oldAttrs <- maybe (return Set.empty) namedNodeMapGetNames =<< elementGetAttributes e-      forM_ (Set.toList $ oldAttrs `Set.difference` Map.keysSet newAttrs) $ elementRemoveAttribute e-      imapM_ (elementSetAttribute e) newAttrs --TODO: avoid re-setting unchanged attributes; possibly do the compare using Align in haskell+      oldAttrs <- maybe (return Set.empty) namedNodeMapGetNames =<< getAttributes e+      forM_ (Set.toList $ oldAttrs `Set.difference` Map.keysSet newAttrs) $ removeAttribute e+      imapM_ (setAttribute e) newAttrs --TODO: avoid re-setting unchanged attributes; possibly do the compare using Align in haskell -buildEmptyElement :: (MonadWidget t m, Attributes m attrs) => String -> attrs -> m HTMLElement-buildEmptyElement elementTag attrs = do+buildEmptyElementNS :: (MonadWidget t m, Attributes m attrs) => Maybe String -> String -> attrs -> m Element+buildEmptyElementNS mns elementTag attrs = do   doc <- askDocument   p <- askParent-  Just e <- liftIO $ documentCreateElement doc elementTag+  Just e <- liftIO $ case mns of+    Nothing -> createElement doc (Just elementTag)+    Just ns -> createElementNS doc (Just ns) (Just elementTag)   addAttributes attrs e-  _ <- liftIO $ nodeAppendChild p $ Just e-  return $ castToHTMLElement e+  _ <- appendChild p $ Just e+  return $ castToElement e +buildEmptyElement :: (MonadWidget t m, Attributes m attrs) => String -> attrs -> m Element+buildEmptyElement = buildEmptyElementNS Nothing+ -- We need to decide what type of attrs we've got statically, because it will often be a recursively defined value, in which case inspecting it will lead to a cycle-buildElement :: (MonadWidget t m, Attributes m attrs) => String -> attrs -> m a -> m (HTMLElement, a)-buildElement elementTag attrs child = do-  e <- buildEmptyElement elementTag attrs+buildElementNS :: (MonadWidget t m, Attributes m attrs) => Maybe String -> String -> attrs -> m a -> m (Element, a)+buildElementNS mns elementTag attrs child = do+  e <- buildEmptyElementNS mns elementTag attrs   result <- subWidget (toNode e) child   return (e, result) -namedNodeMapGetNames :: IsNamedNodeMap self => self -> IO (Set String)+buildElement :: (MonadWidget t m, Attributes m attrs) => String -> attrs -> m a -> m (Element, a)+buildElement = buildElementNS Nothing++namedNodeMapGetNames :: NamedNodeMap -> IO (Set String) namedNodeMapGetNames self = do-  l <- namedNodeMapGetLength self+  l <- NNM.getLength self   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-  liftM Set.fromList $ forM locations $ \i -> do-    Just n <- namedNodeMapItem self i-    nodeGetNodeName n+  liftM (Set.fromList . catMaybes) $ forM locations $ \i -> do+    Just n <- NNM.item self i+    getNodeName n  text :: MonadWidget t m => String -> m () text = void . text'@@ -90,8 +112,8 @@ text' s = do   doc <- askDocument   p <- askParent-  Just n <- liftIO $ documentCreateTextNode doc s-  _ <- liftIO $ nodeAppendChild p $ Just n+  Just n <- createTextNode doc s+  _ <- appendChild p $ Just n   return n  dynText :: MonadWidget t m => Dynamic t String -> m ()@@ -99,141 +121,117 @@   n <- text' ""   schedulePostBuild $ do     curS <- sample $ current s-    liftIO $ nodeSetNodeValue n curS-  addVoidAction $ fmap (liftIO . nodeSetNodeValue n) $ updated s+    setNodeValue n $ Just curS+  addVoidAction $ fmap (setNodeValue n . Just) $ updated s  display :: (MonadWidget t m, Show a) => Dynamic t a -> m () display a = dynText =<< mapDyn show a  --TODO: Should this be renamed to 'widgetView' for consistency with 'widgetHold'?+-- | Given a Dynamic of widget-creating actions, create a widget that is recreated whenever the Dynamic updates.+--   The returned Event of widget results occurs when the Dynamic does.+--   Note:  Often, the type 'a' is an Event, in which case the return value is an Event-of-Events that would typically be flattened. dyn :: MonadWidget t m => Dynamic t (m a) -> m (Event t a) dyn child = do-  startPlaceholder <- text' ""-  endPlaceholder <- text' ""-  (newChildBuilt, newChildBuiltTriggerRef) <- newEventWithTriggerRef-  let e = fmap snd newChildBuilt --TODO: Get rid of this hack-  childVoidAction <- hold never e-  performEvent_ $ fmap (const $ return ()) e --TODO: Get rid of this hack-  addVoidAction $ switch childVoidAction-  doc <- askDocument-  runWidget <- getRunWidget-  let build c = do-        Just df <- liftIO $ documentCreateDocumentFragment doc-        (result, postBuild, voidActions) <- runWidget df c-        runFrameWithTriggerRef newChildBuiltTriggerRef (result, voidActions)-        postBuild-        Just p <- liftIO $ nodeGetParentNode endPlaceholder-        _ <- liftIO $ nodeInsertBefore p (Just df) (Just endPlaceholder)-        return ()-  schedulePostBuild $ do-    c <- sample $ current child-    build c-  addVoidAction $ ffor (updated child) $ \newChild -> do-    liftIO $ deleteBetweenExclusive startPlaceholder endPlaceholder-    build newChild-  return $ fmap fst newChildBuilt+  postBuild <- getPostBuild+  let newChild = leftmost [updated child, tag (current child) postBuild]+  liftM snd $ widgetHoldInternal (return ()) newChild +-- | Given an initial widget and an Event of widget-creating actions, create a widget that is recreated whenever the Event fires.+--   The returned Dynamic of widget results occurs when the Event does.+--   Note:  Often, the type 'a' is an Event, in which case the return value is a Dynamic-of-Events that would typically be flattened. widgetHold :: MonadWidget t m => m a -> Event t (m a) -> m (Dynamic t a) widgetHold child0 newChild = do+  (result0, newResult) <- widgetHoldInternal child0 newChild+  holdDyn result0 newResult++widgetHoldInternal :: MonadWidget t m => m a -> Event t (m b) -> m (a, Event t b)+widgetHoldInternal child0 newChild = do   startPlaceholder <- text' ""-  result0 <- child0 -- I'm pretty sure this is wrong; the void actions should get removed when the child is swapped out+  (result0, childVoidAction0) <- do+    p <- askParent+    subWidgetWithVoidActions p child0   endPlaceholder <- text' ""   (newChildBuilt, newChildBuiltTriggerRef) <- newEventWithTriggerRef   performEvent_ $ fmap (const $ return ()) newChildBuilt --TODO: Get rid of this hack-  childVoidAction <- hold never $ fmap snd newChildBuilt+  childVoidAction <- hold childVoidAction0 $ fmap snd newChildBuilt   addVoidAction $ switch childVoidAction --TODO: Should this be a switchPromptly?   doc <- askDocument   runWidget <- getRunWidget-  let build c = do-        Just df <- liftIO $ documentCreateDocumentFragment doc-        (result, postBuild, voidActions) <- runWidget df c-        runFrameWithTriggerRef newChildBuiltTriggerRef (result, voidActions)-        postBuild-        mp <- liftIO $ nodeGetParentNode endPlaceholder-        case mp of-          Nothing -> return () --TODO: Is this right?-          Just p -> do-            _ <- liftIO $ nodeInsertBefore p (Just df) (Just endPlaceholder)-            return ()-        return ()   addVoidAction $ ffor newChild $ \c -> do+    Just df <- createDocumentFragment doc+    (result, postBuild, voidActions) <- runWidget df c+    runFrameWithTriggerRef newChildBuiltTriggerRef (result, voidActions)+    postBuild     liftIO $ deleteBetweenExclusive startPlaceholder endPlaceholder-    build c-  holdDyn result0 $ fmap fst newChildBuilt+    mp' <- getParentNode endPlaceholder+    forM_ mp' $ \p' -> insertBefore p' (Just df) (Just endPlaceholder)+    return ()+  return (result0, fmap fst newChildBuilt) +diffMapNoEq :: (Ord k) => Map k v -> Map k v -> Map k (Maybe v)+diffMapNoEq olds news = flip Map.mapMaybe (align olds news) $ \case+  This _ -> Just Nothing+  These _ new -> Just $ Just new+  That new -> Just $ Just new++applyMap :: Ord k => Map k v -> Map k (Maybe v) -> Map k v+applyMap olds diffs = flip Map.mapMaybe (align olds diffs) $ \case+  This old -> Just old+  These _ new -> new+  That new -> new+ --TODO: Something better than Dynamic t (Map k v) - we want something where the Events carry diffs, not the whole value-listWithKey :: (Ord k, MonadWidget t m) => Dynamic t (Map k v) -> (k -> Dynamic t v -> m a) -> m (Dynamic t (Map k a))+listWithKey :: forall t k v m a. (Ord k, MonadWidget t m) => Dynamic t (Map k v) -> (k -> Dynamic t v -> m a) -> m (Dynamic t (Map k a)) listWithKey vals mkChild = do-  doc <- askDocument-  endPlaceholder <- text' ""-  (newChildren, newChildrenTriggerRef) <- newEventWithTriggerRef-  performEvent_ $ fmap (const $ return ()) newChildren --TODO: Get rid of this hack-  children <- hold Map.empty  newChildren-  addVoidAction $ switch $ fmap (mergeWith (>>) . map snd . Map.elems) children-  runWidget <- getRunWidget-  let buildChild df k v = runWidget df $ do-        childStart <- text' ""-        result <- mkChild k =<< holdDyn v (fmapMaybe (Map.lookup k) (updated vals))-        childEnd <- text' ""-        return (result, (childStart, childEnd))-  schedulePostBuild $ do-    Just df <- liftIO $ documentCreateDocumentFragment doc-    curVals <- sample $ current vals-    initialState <- iforM curVals $ \k v -> do-      (result, postBuild, voidAction) <- buildChild df k v-      return ((result, voidAction), postBuild)-    runFrameWithTriggerRef newChildrenTriggerRef $ fmap fst initialState --TODO: Do all these in a single runFrame-    sequence_ $ fmap snd initialState-    Just p <- liftIO $ nodeGetParentNode endPlaceholder-    _ <- liftIO $ nodeInsertBefore p (Just df) (Just endPlaceholder)-    return ()-  addVoidAction $ flip fmap (updated vals) $ \newVals -> do-    curState <- sample children-    --TODO: Should we remove the parent from the DOM first to avoid reflows?-    (newState, postBuild) <- flip runStateT (return ()) $ liftM (Map.mapMaybe id) $ iforM (align curState newVals) $ \k -> \case-      This ((_, (start, end)), _) -> do-        liftIO $ deleteBetweenInclusive start end-        return Nothing-      That v -> do-        Just df <- liftIO $ documentCreateDocumentFragment doc-        (childResult, childPostBuild, childVoidAction) <- lift $ buildChild df k v-        let s = (childResult, childVoidAction)-        modify (>>childPostBuild)-        let placeholder = case Map.lookupGT k curState of-              Nothing -> endPlaceholder-              Just (_, ((_, (start, _)), _)) -> start-        Just p <- liftIO $ nodeGetParentNode placeholder-        _ <- liftIO $ nodeInsertBefore p (Just df) (Just placeholder)-        return $ Just s-      These state _ -> do-        return $ Just state-    runFrameWithTriggerRef newChildrenTriggerRef newState-    postBuild-  holdDyn Map.empty $ fmap (fmap (fst . fst)) newChildren+  postBuild <- getPostBuild+  rec sentVals :: Dynamic t (Map k v) <- foldDyn (flip applyMap) Map.empty changeVals+      let changeVals :: Event t (Map k (Maybe v))+          changeVals = attachWith diffMapNoEq (current sentVals) $ leftmost+                         [ updated vals+                         , tag (current vals) postBuild+                         ]+  listWithKeyShallowDiff Map.empty changeVals $ \k v0 dv -> do+    mkChild k =<< holdDyn v0 dv -listWithKey' :: forall t m k v a. (Ord k, MonadWidget t m) => Map k v -> Event t (Map k (Maybe v)) -> (k -> v -> Event t v -> m a) -> m (Dynamic t (Map k a))-listWithKey' initialVals valsChanged mkChild = do+{-# DEPRECATED listWithKey' "listWithKey' has been renamed to listWithKeyShallowDiff; also, its behavior has changed to fix a bug where children were always rebuilt (never updated)" #-}+listWithKey' :: (Ord k, MonadWidget t m) => Map k v -> Event t (Map k (Maybe v)) -> (k -> v -> Event t v -> m a) -> m (Dynamic t (Map k a))+listWithKey' = listWithKeyShallowDiff++-- | Display the given map of items (in key order) using the builder function provided, and update it with the given event.  'Nothing' update entries will delete the corresponding children, and 'Just' entries will create them if they do not exist or send an update event to them if they do.+listWithKeyShallowDiff :: (Ord k, MonadWidget t m) => Map k v -> Event t (Map k (Maybe v)) -> (k -> v -> Event t v -> m a) -> m (Dynamic t (Map k a))+listWithKeyShallowDiff initialVals valsChanged mkChild = do+  let childValChangedSelector = fanMap $ fmap (Map.mapMaybe id) valsChanged+  sentVals <- foldDyn (flip applyMap) Map.empty $ fmap (fmap (fmap (\_ -> ()))) valsChanged+  let relevantDiff diff _ = case diff of+        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+        Just _ -> Nothing -- We don't want to let spurious re-creations of items through+  listHoldWithKey initialVals (attachWith (flip (Map.differenceWith relevantDiff)) (current sentVals) valsChanged) $ \k v ->+    mkChild k v $ Reflex.select childValChangedSelector $ Const2 k++-- | 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.+listHoldWithKey :: (Ord k, MonadWidget t m) => Map k v -> Event t (Map k (Maybe v)) -> (k -> v -> m a) -> m (Dynamic t (Map k a))+listHoldWithKey initialVals valsChanged mkChild = do   doc <- askDocument   endPlaceholder <- text' ""   (newChildren, newChildrenTriggerRef) <- newEventWithTriggerRef --  performEvent_ $ fmap (const $ return ()) newChildren --TODO: Get rid of this hack   runWidget <- getRunWidget-  let childValChangedSelector :: EventSelector t (Const2 k v)-      childValChangedSelector = fanMap $ fmap (Map.mapMaybe id) valsChanged-      buildChild df k v = runWidget df $ wrapChild k v+  let buildChild df k v = runWidget df $ wrapChild k v       wrapChild k v = do         childStart <- text' ""-        result <- mkChild k v $ select childValChangedSelector $ Const2 k+        result <- mkChild k v         childEnd <- text' ""         return (result, (childStart, childEnd))-  Just dfOrig <- liftIO $ documentCreateDocumentFragment doc+  Just dfOrig <- createDocumentFragment doc   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+  stateRef <- liftIO $ newIORef initialState   children <- holdDyn initialState newChildren   addVoidAction $ switch $ fmap (mergeWith (>>) . map snd . Map.elems) $ current children-  Just pOrig <- liftIO $ nodeGetParentNode endPlaceholder-  _ <- liftIO $ nodeInsertBefore pOrig (Just dfOrig) (Just endPlaceholder)+  mpOrig <- getParentNode endPlaceholder+  forM_ mpOrig $ \pOrig -> insertBefore pOrig (Just dfOrig) (Just endPlaceholder)   addVoidAction $ flip fmap valsChanged $ \newVals -> do-    curState <- sample $ current children+    curState <- liftIO $ readIORef stateRef     --TODO: Should we remove the parent from the DOM first to avoid reflows?     (newState, postBuild) <- flip runStateT (return ()) $ liftM (Map.mapMaybe id) $ iforM (align curState newVals) $ \k -> \case       These ((_, (start, end)), _) Nothing -> do -- Deleting child@@ -241,95 +239,62 @@         return Nothing       These ((_, (start, end)), _) (Just v) -> do -- Replacing existing child         liftIO $ deleteBetweenExclusive start end-        Just df <- liftIO $ documentCreateDocumentFragment doc+        Just df <- createDocumentFragment doc         (childResult, childPostBuild, childVoidAction) <- lift $ buildChild df k v         let s = (childResult, childVoidAction)         modify (>>childPostBuild)-        Just p <- liftIO $ nodeGetParentNode end-        _ <- liftIO $ nodeInsertBefore p (Just df) (Just end)+        mp <- getParentNode end+        forM_ mp $ \p -> insertBefore p (Just df) (Just end)         return $ Just s       That Nothing -> return Nothing -- Deleting non-existent child       That (Just v) -> do -- Creating new child-        Just df <- liftIO $ documentCreateDocumentFragment doc+        Just df <- createDocumentFragment doc         (childResult, childPostBuild, childVoidAction) <- lift $ buildChild df k v         let s = (childResult, childVoidAction)         modify (>>childPostBuild)         let placeholder = case Map.lookupGT k curState of               Nothing -> endPlaceholder               Just (_, ((_, (start, _)), _)) -> start-        Just p <- liftIO $ nodeGetParentNode placeholder-        _ <- liftIO $ nodeInsertBefore p (Just df) (Just placeholder)+        mp <- getParentNode placeholder+        forM_ mp $ \p -> insertBefore p (Just df) (Just placeholder)         return $ Just s       This state -> do -- No change         return $ Just state+    liftIO $ writeIORef stateRef newState     runFrameWithTriggerRef newChildrenTriggerRef newState     postBuild   mapDyn (fmap (fst . fst)) children  --TODO: Something better than Dynamic t (Map k v) - we want something where the Events carry diffs, not the whole value+-- | Create a dynamically-changing set of Event-valued widgets.+--   This is like listWithKey, specialized for widgets returning (Event t a).  listWithKey would return 'Dynamic t (Map k (Event t a))' in this scenario, but listViewWithKey flattens this to 'Event t (Map k a)' via 'switch'. listViewWithKey :: (Ord k, MonadWidget t m) => Dynamic t (Map k v) -> (k -> Dynamic t v -> m (Event t a)) -> m (Event t (Map k a)) listViewWithKey vals mkChild = liftM (switch . fmap mergeMap) $ listViewWithKey' vals mkChild  listViewWithKey' :: (Ord k, MonadWidget t m) => Dynamic t (Map k v) -> (k -> Dynamic t v -> m a) -> m (Behavior t (Map k a))-listViewWithKey' vals mkChild = do-  doc <- askDocument-  endPlaceholder <- text' ""-  (newChildren, newChildrenTriggerRef) <- newEventWithTriggerRef-  performEvent_ $ fmap (const $ return ()) newChildren --TODO: Get rid of this hack-  children <- hold Map.empty newChildren-  addVoidAction $ switch $ fmap (mergeWith (>>) . map snd . Map.elems) children-  runWidget <- getRunWidget-  let buildChild df k v = runWidget df $ do-        childStart <- text' ""-        result <- mkChild k =<< holdDyn v (fmapMaybe (Map.lookup k) (updated vals))-        childEnd <- text' ""-        return (result, (childStart, childEnd))-  schedulePostBuild $ do-    Just df <- liftIO $ documentCreateDocumentFragment doc-    curVals <- sample $ current vals-    initialState <- iforM curVals $ \k v -> do-      (result, postBuild, voidAction) <- buildChild df k v-      return ((result, voidAction), postBuild)-    runFrameWithTriggerRef newChildrenTriggerRef $ fmap fst initialState --TODO: Do all these in a single runFrame-    sequence_ $ fmap snd initialState-    Just p <- liftIO $ nodeGetParentNode endPlaceholder-    _ <- liftIO $ nodeInsertBefore p (Just df) (Just endPlaceholder)-    return ()-  addVoidAction $ flip fmap (updated vals) $ \newVals -> do-    curState <- sample children-    --TODO: Should we remove the parent from the DOM first to avoid reflows?-    (newState, postBuild) <- flip runStateT (return ()) $ liftM (Map.mapMaybe id) $ iforM (align curState newVals) $ \k -> \case-      This ((_, (start, end)), _) -> do-        liftIO $ deleteBetweenInclusive start end-        return Nothing-      That v -> do-        Just df <- liftIO $ documentCreateDocumentFragment doc-        (childResult, childPostBuild, childVoidAction) <- lift $ buildChild df k v-        let s = (childResult, childVoidAction)-        modify (>>childPostBuild)-        let placeholder = case Map.lookupGT k curState of-              Nothing -> endPlaceholder-              Just (_, ((_, (start, _)), _)) -> start-        Just p <- liftIO $ nodeGetParentNode placeholder-        _ <- liftIO $ nodeInsertBefore p (Just df) (Just placeholder)-        return $ Just s-      These state _ -> do-        return $ Just state-    runFrameWithTriggerRef newChildrenTriggerRef newState-    postBuild-  return $ fmap (fmap (fst . fst)) children----TODO: Deduplicate the various list*WithKey* implementations+listViewWithKey' vals mkChild = liftM current $ listWithKey vals mkChild -selectViewListWithKey_ :: forall t m k v a. (MonadWidget t m, Ord k) => Dynamic t k -> Dynamic t (Map k v) -> (k -> Dynamic t v -> Dynamic t Bool -> m (Event t a)) -> m (Event t k)-selectViewListWithKey_ selection vals mkChild = do+-- | Create a dynamically-changing set of widgets, one of which is selected at any time.+selectViewListWithKey :: forall t m k v a. (MonadWidget t m, Ord k)+  => Dynamic t k          -- ^ Current selection key+  -> Dynamic t (Map k v)  -- ^ Dynamic key/value map+  -> (k -> Dynamic t v -> Dynamic t Bool -> m (Event t a)) -- ^ Function to create a widget for a given key from Dynamic value and Dynamic Bool indicating if this widget is currently selected+  -> m (Event t (k, a))        -- ^ Event that fires when any child's return Event fires.  Contains key of an arbitrary firing widget.+selectViewListWithKey selection vals mkChild = do   let selectionDemux = demux selection -- For good performance, this value must be shared across all children   selectChild <- listWithKey vals $ \k v -> do     selected <- getDemuxed selectionDemux k     selectSelf <- mkChild k v selected-    return $ fmap (const k) selectSelf+    return $ fmap ((,) k) selectSelf   liftM switchPromptlyDyn $ mapDyn (leftmost . Map.elems) selectChild +selectViewListWithKey_ :: forall t m k v a. (MonadWidget t m, Ord k)+  => Dynamic t k          -- ^ Current selection key+  -> Dynamic t (Map k v)  -- ^ Dynamic key/value map+  -> (k -> Dynamic t v -> Dynamic t Bool -> m (Event t a)) -- ^ Function to create a widget for a given key from Dynamic value and Dynamic Bool indicating if this widget is currently selected+  -> m (Event t k)        -- ^ Event that fires when any child's return Event fires.  Contains key of an arbitrary firing widget.+selectViewListWithKey_ selection vals mkChild = liftM (fmap fst) $ selectViewListWithKey selection vals mkChild+ -------------------------------------------------------------------------------- -- Basic DOM manipulation helpers --------------------------------------------------------------------------------@@ -337,47 +302,56 @@ -- | s and e must both be children of the same node and s must precede e deleteBetweenExclusive :: (IsNode start, IsNode end) => start -> end -> IO () deleteBetweenExclusive s e = do-  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+  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   case mCurrentParent of     Nothing -> return () --TODO: Is this the right behavior?     Just currentParent -> do       let go = do-            Just x <- nodeGetPreviousSibling e -- This can't be Nothing because we should hit 's' first+            Just x <- getPreviousSibling e -- This can't be Nothing because we should hit 's' first             when (toNode s /= toNode x) $ do-              _ <- nodeRemoveChild currentParent $ Just x+              _ <- removeChild currentParent $ Just x               go       go  -- | s and e must both be children of the same node and s must precede e deleteBetweenInclusive :: (IsNode start, IsNode end) => start -> end -> IO () deleteBetweenInclusive s e = do-  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+  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   case mCurrentParent of     Nothing -> return () --TODO: Is this the right behavior?     Just currentParent -> do       let go = do-            Just x <- nodeGetPreviousSibling e -- This can't be Nothing because we should hit 's' first-            _ <- nodeRemoveChild currentParent $ Just x+            Just x <- getPreviousSibling e -- This can't be Nothing because we should hit 's' first+            _ <- removeChild currentParent $ Just x             when (toNode s /= toNode x) go       go-      _ <- nodeRemoveChild currentParent $ Just e+      _ <- removeChild currentParent $ Just e       return () +nodeClear :: IsNode self => self -> IO ()+nodeClear n = do+  mfc <- getFirstChild n+  case mfc of+    Nothing -> return ()+    Just fc -> do+      _ <- removeChild n $ Just fc+      nodeClear n+ -------------------------------------------------------------------------------- -- Adapters -------------------------------------------------------------------------------- -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)+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) wrapDomEvent element elementOnevent getValue = wrapDomEventMaybe element elementOnevent $ liftM Just getValue -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)+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) wrapDomEventMaybe element elementOnevent getValue = do   postGui <- askPostGui   runWithActions <- askRunWithActions   e <- newEventWithTrigger $ \et -> do         unsubscribe <- {-# SCC "a" #-} liftIO $ {-# SCC "b" #-} elementOnevent element $ {-# SCC "c" #-} do           mv <- {-# SCC "d" #-} getValue-          forM_ mv $ \v -> liftIO $ postGui $ runWithActions [et :=> v]+          forM_ mv $ \v -> liftIO $ postGui $ runWithActions [et :=> Identity v]         return $ liftIO $ do           {-# SCC "e" #-} unsubscribe   return $! {-# SCC "f" #-} e@@ -411,11 +385,11 @@    | MouseoutTag    | MouseoverTag    | MouseupTag---   | 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+   | MousewheelTag    | ScrollTag    | SelectTag    | SubmitTag---   | WheelTag -- See MousewheelTag+   | WheelTag    | BeforecutTag    | CutTag    | BeforecopyTag@@ -459,11 +433,11 @@   Mouseout :: EventName 'MouseoutTag   Mouseover :: EventName 'MouseoverTag   Mouseup :: EventName 'MouseupTag-  --Mousewheel :: EventName 'MousewheelTag+  Mousewheel :: EventName 'MousewheelTag   Scroll :: EventName 'ScrollTag   Select :: EventName 'SelectTag   Submit :: EventName 'SubmitTag-  --Wheel :: EventName 'WheelTag+  Wheel :: EventName 'WheelTag   Beforecut :: EventName 'BeforecutTag   Cut :: EventName 'CutTag   Beforecopy :: EventName 'BeforecopyTag@@ -480,8 +454,8 @@  type family EventType en where   EventType 'AbortTag = UIEvent-  EventType 'BlurTag = UIEvent-  EventType 'ChangeTag = UIEvent+  EventType 'BlurTag = FocusEvent+  EventType 'ChangeTag = DOM.Event   EventType 'ClickTag = MouseEvent   EventType 'ContextmenuTag = MouseEvent   EventType 'DblclickTag = MouseEvent@@ -493,87 +467,87 @@   EventType 'DragstartTag = MouseEvent   EventType 'DropTag = MouseEvent   EventType 'ErrorTag = UIEvent-  EventType 'FocusTag = UIEvent-  EventType 'InputTag = UIEvent-  EventType 'InvalidTag = UIEvent-  EventType 'KeydownTag = UIEvent-  EventType 'KeypressTag = UIEvent-  EventType 'KeyupTag = UIEvent+  EventType 'FocusTag = FocusEvent+  EventType 'InputTag = DOM.Event+  EventType 'InvalidTag = DOM.Event+  EventType 'KeydownTag = KeyboardEvent+  EventType 'KeypressTag = KeyboardEvent+  EventType 'KeyupTag = KeyboardEvent   EventType 'LoadTag = UIEvent   EventType 'MousedownTag = MouseEvent-  EventType 'MouseenterTag = UIEvent-  EventType 'MouseleaveTag = UIEvent+  EventType 'MouseenterTag = MouseEvent+  EventType 'MouseleaveTag = MouseEvent   EventType 'MousemoveTag = MouseEvent   EventType 'MouseoutTag = MouseEvent   EventType 'MouseoverTag = MouseEvent   EventType 'MouseupTag = MouseEvent-  --EventType 'MousewheelTag = MouseEvent+  EventType 'MousewheelTag = MouseEvent   EventType 'ScrollTag = UIEvent   EventType 'SelectTag = UIEvent-  EventType 'SubmitTag = UIEvent-  --EventType 'WheelTag = UIEvent-  EventType 'BeforecutTag = UIEvent-  EventType 'CutTag = UIEvent-  EventType 'BeforecopyTag = UIEvent-  EventType 'CopyTag = UIEvent-  EventType 'BeforepasteTag = UIEvent-  EventType 'PasteTag = UIEvent-  EventType 'ResetTag = UIEvent-  EventType 'SearchTag = UIEvent-  EventType 'SelectstartTag = UIEvent-  EventType 'TouchstartTag = UIEvent-  EventType 'TouchmoveTag = UIEvent-  EventType 'TouchendTag = UIEvent-  EventType 'TouchcancelTag = UIEvent+  EventType 'SubmitTag = DOM.Event+  EventType 'WheelTag = WheelEvent+  EventType 'BeforecutTag = DOM.Event+  EventType 'CutTag = DOM.Event+  EventType 'BeforecopyTag = DOM.Event+  EventType 'CopyTag = DOM.Event+  EventType 'BeforepasteTag = DOM.Event+  EventType 'PasteTag = DOM.Event+  EventType 'ResetTag = DOM.Event+  EventType 'SearchTag = DOM.Event+  EventType 'SelectstartTag = DOM.Event+  EventType 'TouchstartTag = TouchEvent+  EventType 'TouchmoveTag = TouchEvent+  EventType 'TouchendTag = TouchEvent+  EventType 'TouchcancelTag = TouchEvent -onEventName :: IsElement e => EventName en -> e -> EventM (EventType en) e () -> IO (IO ())-onEventName en = case en of-  Abort -> elementOnabort-  Blur -> elementOnblur-  Change -> elementOnchange-  Click -> elementOnclick-  Contextmenu -> elementOncontextmenu-  Dblclick -> elementOndblclick-  Drag -> elementOndrag-  Dragend -> elementOndragend-  Dragenter -> elementOndragenter-  Dragleave -> elementOndragleave-  Dragover -> elementOndragover-  Dragstart -> elementOndragstart-  Drop -> elementOndrop-  Error -> elementOnerror-  Focus -> elementOnfocus-  Input -> elementOninput-  Invalid -> elementOninvalid-  Keydown -> elementOnkeydown-  Keypress -> elementOnkeypress-  Keyup -> elementOnkeyup-  Load -> elementOnload-  Mousedown -> elementOnmousedown-  Mouseenter -> elementOnmouseenter-  Mouseleave -> elementOnmouseleave-  Mousemove -> elementOnmousemove-  Mouseout -> elementOnmouseout-  Mouseover -> elementOnmouseover-  Mouseup -> elementOnmouseup-  --Mousewheel -> elementOnmousewheel-  Scroll -> elementOnscroll-  Select -> elementOnselect-  Submit -> elementOnsubmit-  --Wheel -> elementOnwheel-  Beforecut -> elementOnbeforecut-  Cut -> elementOncut-  Beforecopy -> elementOnbeforecopy-  Copy -> elementOncopy-  Beforepaste -> elementOnbeforepaste-  Paste -> elementOnpaste-  Reset -> elementOnreset-  Search -> elementOnsearch-  Selectstart -> elementOnselectstart-  Touchstart -> elementOntouchstart-  Touchmove -> elementOntouchmove-  Touchend -> elementOntouchend-  Touchcancel -> elementOntouchcancel+onEventName :: IsElement e => EventName en -> e -> EventM e (EventType en) () -> IO (IO ())+onEventName en e = case en of+  Abort -> on e E.abort+  Blur -> on e E.blurEvent+  Change -> on e E.change+  Click -> on e E.click+  Contextmenu -> on e E.contextMenu+  Dblclick -> on e E.dblClick+  Drag -> on e E.drag+  Dragend -> on e E.dragEnd+  Dragenter -> on e E.dragEnter+  Dragleave -> on e E.dragLeave+  Dragover -> on e E.dragOver+  Dragstart -> on e E.dragStart+  Drop -> on e E.drop+  Error -> on e E.error+  Focus -> on e E.focusEvent+  Input -> on e E.input+  Invalid -> on e E.invalid+  Keydown -> on e E.keyDown+  Keypress -> on e E.keyPress+  Keyup -> on e E.keyUp+  Load -> on e E.load+  Mousedown -> on e E.mouseDown+  Mouseenter -> on e E.mouseEnter+  Mouseleave -> on e E.mouseLeave+  Mousemove -> on e E.mouseMove+  Mouseout -> on e E.mouseOut+  Mouseover -> on e E.mouseOver+  Mouseup -> on e E.mouseUp+  Mousewheel -> on e E.mouseWheel+  Scroll -> on e E.scroll+  Select -> on e E.select+  Submit -> on e E.submit+  Wheel -> on e E.wheel+  Beforecut -> on e E.beforeCut+  Cut -> on e E.cut+  Beforecopy -> on e E.beforeCopy+  Copy -> on e E.copy+  Beforepaste -> on e E.beforePaste+  Paste -> on e E.paste+  Reset -> on e E.reset+  Search -> on e E.search+  Selectstart -> on e E.selectStart+  Touchstart -> on e E.touchStart+  Touchmove -> on e E.touchMove+  Touchend -> on e E.touchEnd+  Touchcancel -> on e E.touchCancel  newtype EventResult en = EventResult { unEventResult :: EventResultType en } @@ -581,6 +555,8 @@   EventResultType 'ClickTag = ()   EventResultType 'DblclickTag = ()   EventResultType 'KeypressTag = Int+  EventResultType 'KeydownTag = Int+  EventResultType 'KeyupTag = Int   EventResultType 'ScrollTag = Int   EventResultType 'MousemoveTag = (Int, Int)   EventResultType 'MousedownTag = (Int, Int)@@ -589,40 +565,74 @@   EventResultType 'MouseleaveTag = ()   EventResultType 'FocusTag = ()   EventResultType 'BlurTag = ()+  EventResultType 'ChangeTag = ()+  EventResultType 'DragTag = ()+  EventResultType 'DragendTag = ()+  EventResultType 'DragenterTag = ()+  EventResultType 'DragleaveTag = ()+  EventResultType 'DragoverTag = ()+  EventResultType 'DragstartTag = ()+  EventResultType 'DropTag = ()+  EventResultType 'AbortTag = ()+  EventResultType 'ContextmenuTag = ()+  EventResultType 'ErrorTag = ()+  EventResultType 'InputTag = ()+  EventResultType 'InvalidTag = ()+  EventResultType 'LoadTag = ()+  EventResultType 'MouseoutTag = ()+  EventResultType 'MouseoverTag = ()+  EventResultType 'SelectTag = ()+  EventResultType 'SubmitTag = ()+  EventResultType 'BeforecutTag = ()+  EventResultType 'CutTag = ()+  EventResultType 'BeforecopyTag = ()+  EventResultType 'CopyTag = ()+  EventResultType 'BeforepasteTag = ()+  EventResultType 'PasteTag = ()+  EventResultType 'ResetTag = ()+  EventResultType 'SearchTag = ()+  EventResultType 'SelectstartTag = ()+  EventResultType 'TouchstartTag = ()+  EventResultType 'TouchmoveTag = ()+  EventResultType 'TouchendTag = ()+  EventResultType 'TouchcancelTag = ()+  EventResultType 'MousewheelTag = ()+  EventResultType 'WheelTag = () -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))+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)) wrapDomEventsMaybe element handlers = do   postGui <- askPostGui   runWithActions <- askRunWithActions   e <- newFanEventWithTrigger $ \(WrapArg en) et -> do-        unsubscribe <- liftIO $ (onEventName en) element $ do+        unsubscribe <- onEventName en element $ do           mv <- handlers en-          forM_ mv $ \v -> liftIO $ postGui $ runWithActions [et :=> v]+          forM_ mv $ \v -> liftIO $ postGui $ runWithActions [et :=> Identity v]         return $ liftIO $ do           unsubscribe   return $! e -getKeyEvent :: EventM UIEvent e Int+getKeyEvent :: EventM e KeyboardEvent Int getKeyEvent = do   e <- event-  liftIO $ do-    which <- uiEventGetWhich e-    if which /= 0 then return which else do-      charCode <- uiEventGetCharCode e-      if charCode /= 0 then return charCode else-        uiEventGetKeyCode e+  which <- getWhich e+  if which /= 0 then return which else do+    charCode <- getCharCode e+    if charCode /= 0 then return charCode else+      getKeyCode e -getMouseEventCoords :: EventM MouseEvent e (Int, Int)+getMouseEventCoords :: EventM e MouseEvent (Int, Int) getMouseEventCoords = do   e <- event-  liftIO $ bisequence (mouseEventGetX e, mouseEventGetY e)+  bisequence (getX e, getY e) -defaultDomEventHandler :: IsElement e => e -> EventName en -> EventM (EventType en) e (Maybe (EventResult en))+defaultDomEventHandler :: IsElement e => e -> EventName en -> EventM e (EventType en) (Maybe (EventResult en)) defaultDomEventHandler e evt = liftM (Just . EventResult) $ case evt of   Click -> return ()   Dblclick -> return ()   Keypress -> getKeyEvent-  Scroll -> liftIO $ elementGetScrollTop e+  Scroll -> getScrollTop e+  Keydown -> getKeyEvent+  Keyup -> getKeyEvent   Mousemove -> getMouseEventCoords   Mouseup -> getMouseEventCoords   Mousedown -> getMouseEventCoords@@ -630,97 +640,159 @@   Mouseleave -> return ()   Focus -> return ()   Blur -> return ()+  Change -> return ()+  Drag -> return ()+  Dragend -> return ()+  Dragenter -> return ()+  Dragleave -> return ()+  Dragover -> return ()+  Dragstart -> return ()+  Drop -> return ()+  Abort -> return ()+  Contextmenu -> return ()+  Error -> return ()+  Input -> return ()+  Invalid -> return ()+  Load -> return ()+  Mouseout -> return ()+  Mouseover -> return ()+  Select -> return ()+  Submit -> return ()+  Beforecut -> return ()+  Cut -> return ()+  Beforecopy -> return ()+  Copy -> return ()+  Beforepaste -> return ()+  Paste -> return ()+  Reset -> return ()+  Search -> return ()+  Selectstart -> return ()+  Touchstart -> return ()+  Touchmove -> return ()+  Touchend -> return ()+  Touchcancel -> return ()+  Mousewheel -> return ()+  Wheel -> return () -wrapElement :: forall t h m. (Functor (Event t), MonadIO m, MonadSample t m, MonadReflexCreateTrigger t m, Reflex t, HasPostGui t h m) => HTMLElement -> m (El t)-wrapElement e = do-  es <- wrapDomEventsMaybe e $ defaultDomEventHandler e+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)+wrapElement eh e = do+  es <- wrapDomEventsMaybe e $ eh e   return $ El e es -elDynAttr' :: forall t m a. MonadWidget t m => String -> Dynamic t (Map String String) -> m a -> m (El t, a)-elDynAttr' elementTag attrs child = do-  (e, result) <- buildElement elementTag attrs child-  e' <- wrapElement e+{-# INLINABLE elStopPropagationNS #-}+elStopPropagationNS :: (MonadWidget t m, IsEvent (EventType en)) => Maybe String -> String -> EventName en -> m a -> m a+elStopPropagationNS mns elementTag evt child = do+  (e, result) <- buildElementNS mns elementTag (Map.empty :: Map String String) child+  _ <- liftIO $ onEventName evt e stopPropagation+  return result++{-# INLINABLE elWith #-}+elWith :: (MonadWidget t m, Attributes m attrs) => String -> ElConfig attrs -> m a -> m a+elWith elementTag cfg child = do+  (_, result) <- buildElementNS (cfg ^. namespace) elementTag (cfg ^. attributes) child+  return result++{-# INLINABLE elWith' #-}+elWith' :: (MonadWidget t m, Attributes m attrs) => String -> ElConfig attrs -> m a -> m (El t, a)+elWith' elementTag cfg child = do+  (e, result) <- buildElementNS (cfg ^. namespace) elementTag (cfg ^. attributes) child+  e' <- wrapElement defaultDomEventHandler e   return (e', result) +{-# INLINABLE emptyElWith #-}+emptyElWith :: (MonadWidget t m, Attributes m attrs) => String -> ElConfig attrs -> m ()+emptyElWith elementTag cfg = do+  _ <- buildEmptyElementNS (cfg ^. namespace) elementTag (cfg ^. attributes)+  return ()++{-# INLINABLE emptyElWith' #-}+emptyElWith' :: (MonadWidget t m, Attributes m attrs) => String -> ElConfig attrs -> m (El t)+emptyElWith' elementTag cfg = do+  wrapElement defaultDomEventHandler =<< buildEmptyElementNS (cfg ^. namespace) elementTag (cfg ^. attributes)++{-# INLINABLE elDynAttrNS' #-}+elDynAttrNS' :: forall t m a. MonadWidget t m => Maybe String -> String -> Dynamic t (Map String String) -> m a -> m (El t, a)+elDynAttrNS' mns elementTag attrs = elWith' elementTag $+  def & namespace .~ mns+      & elConfig_attributes .~ attrs++{-# INLINABLE elDynAttr' #-}+elDynAttr' :: forall t m a. MonadWidget t m => String -> Dynamic t (Map String String) -> m a -> m (El t, a)+elDynAttr' elementTag attrs = elWith' elementTag $ def & elConfig_attributes .~ attrs+ {-# INLINABLE elAttr #-} elAttr :: forall t m a. MonadWidget t m => String -> Map String String -> m a -> m a-elAttr elementTag attrs child = do-  (_, result) <- buildElement elementTag attrs child-  return result+elAttr elementTag attrs = elWith elementTag $ def & attributes .~ attrs  {-# INLINABLE el' #-} el' :: forall t m a. MonadWidget t m => String -> m a -> m (El t, a)-el' elementTag child = elAttr' elementTag (Map.empty :: AttributeMap) child+el' elementTag = elWith' elementTag def  {-# INLINABLE elAttr' #-} elAttr' :: forall t m a. MonadWidget t m => String -> Map String String -> m a -> m (El t, a)-elAttr' elementTag attrs child = do-  (e, result) <- buildElement elementTag attrs child-  e' <- wrapElement e-  return (e', result)+elAttr' elementTag attrs = elWith' elementTag $ def & attributes .~ attrs  {-# INLINABLE elDynAttr #-} elDynAttr :: forall t m a. MonadWidget t m => String -> Dynamic t (Map String String) -> m a -> m a-elDynAttr elementTag attrs child = do-  (_, result) <- buildElement elementTag attrs child-  return result+elDynAttr elementTag attrs = elWith elementTag $ def & elConfig_attributes .~ attrs  {-# INLINABLE el #-} el :: forall t m a. MonadWidget t m => String -> m a -> m a-el elementTag child = elAttr elementTag Map.empty child+el elementTag = elWith elementTag def  elClass :: forall t m a. MonadWidget t m => String -> String -> m a -> m a-elClass elementTag c child = elAttr elementTag ("class" =: c) child+elClass elementTag c = elWith elementTag $ def & attributes .~ "class" =: c  -------------------------------------------------------------------------------- -- Copied and pasted from Reflex.Widget.Class -------------------------------------------------------------------------------- +-- | Create a dynamically-changing set of widgets from a Dynamic key/value map.+--   Unlike the 'withKey' variants, the child widgets are insensitive to which key they're associated with. list :: (MonadWidget t m, Ord k) => Dynamic t (Map k v) -> (Dynamic t v -> m a) -> m (Dynamic t (Map k a)) list dm mkChild = listWithKey dm (\_ dv -> mkChild dv) +-- | Create a dynamically-changing set of widgets from a Dynamic list. simpleList :: MonadWidget t m => Dynamic t [v] -> (Dynamic t v -> m a) -> m (Dynamic t [a]) simpleList xs mkChild = mapDyn (map snd . Map.toList) =<< flip list mkChild =<< mapDyn (Map.fromList . zip [(1::Int)..]) xs  elDynHtml' :: MonadWidget t m => String -> Dynamic t String -> m (El t) elDynHtml' elementTag html = do   e <- buildEmptyElement elementTag (Map.empty :: Map String String)-  schedulePostBuild $ liftIO . htmlElementSetInnerHTML e =<< sample (current html)-  addVoidAction $ fmap (liftIO . htmlElementSetInnerHTML e) $ updated html-  wrapElement e+  schedulePostBuild $ setInnerHTML e . Just =<< sample (current html)+  addVoidAction $ fmap (setInnerHTML e . Just) $ updated html+  wrapElement defaultDomEventHandler e  elDynHtmlAttr' :: MonadWidget t m => String -> Map String String -> Dynamic t String -> m (El t) elDynHtmlAttr' elementTag attrs html = do   e <- buildEmptyElement elementTag attrs-  schedulePostBuild $ liftIO . htmlElementSetInnerHTML e =<< sample (current html)-  addVoidAction $ fmap (liftIO . htmlElementSetInnerHTML e) $ updated html-  wrapElement e--{-----TODO: Update dynamically-{-# INLINABLE dynHtml #-}-dynHtml :: MonadWidget t m => Dynamic t String -> m ()-dynHtml ds = do-  let mkSelf h = do-        doc <- askDocument-        Just e <- liftIO $ liftM (fmap castToHTMLElement) $ documentCreateElement doc "div"-        liftIO $ htmlElementSetInnerHTML e h-        return e-  eCreated <- performEvent . fmap mkSelf . tagDyn ds =<< getEInit-  putEChildren $ fmap ((:[]) . toNode) eCreated---}+  schedulePostBuild $ setInnerHTML e . Just =<< sample (current html)+  addVoidAction $ fmap (setInnerHTML e . Just) $ updated html+  wrapElement defaultDomEventHandler e  data Link t   = Link { _link_clicked :: Event t ()          } +class HasAttributes a where+  type Attrs a :: *+  attributes :: Lens' a (Attrs a)++instance HasAttributes (ElConfig attrs) where+  type Attrs (ElConfig attrs) = attrs+  attributes = elConfig_attributes++class HasNamespace a where+  namespace :: Lens' a (Maybe String)++instance HasNamespace (ElConfig attrs) where+  namespace = elConfig_namespace+ class HasDomEvent t a where   domEvent :: EventName en -> a -> Event t (EventResultType en)  instance Reflex t => HasDomEvent t (El t) where-  domEvent en el = fmap unEventResult $ select (_el_events el) (WrapArg en)+  domEvent en e = fmap unEventResult $ Reflex.select (_el_events e) (WrapArg en)  linkClass :: MonadWidget t m => String -> String -> m (Link t) linkClass s c = do@@ -732,7 +804,7 @@  button :: MonadWidget t m => String -> m (Event t ()) button s = do-  (e, _) <- el' "button" $ text s+  (e, _) <- elAttr' "button" (Map.singleton "type" "button") $ text s   return $ domEvent Click e  newtype Workflow t m a = Workflow { unWorkflow :: m (a, Event t (Workflow t m a)) }@@ -748,6 +820,9 @@       eReplace <- liftM switch $ hold never $ fmap snd eResult   return $ fmap fst eResult +mapWorkflow :: (MonadWidget t m) => (a -> b) -> Workflow t m a -> Workflow t m b+mapWorkflow f (Workflow x) = Workflow (fmap (\(v,e) -> (f v, fmap (mapWorkflow f) e)) x)+ divClass :: forall t m a. MonadWidget t m => String -> m a -> m a divClass = elClass "div" @@ -759,7 +834,13 @@ blank :: forall t m. MonadWidget t m => m () blank = return () -tableDynAttr :: forall t m r k v. (MonadWidget t m, Show k, Ord k) => String -> [(String, k -> Dynamic t r -> m v)] -> Dynamic t (Map k r) -> (k -> m (Dynamic t (Map String String))) -> m (Dynamic t (Map k (El t, [v])))+-- | A widget to display a table with static columns and dynamic rows.+tableDynAttr :: forall t m r k v. (MonadWidget t m, Show k, Ord k)+  => String                                   -- ^ Class applied to <table> element+  -> [(String, k -> Dynamic t r -> m v)]      -- ^ Columns of (header, row key -> row value -> child widget)+  -> Dynamic t (Map k r)                      -- ^ Map from row key to row value+  -> (k -> m (Dynamic t (Map String String))) -- ^ Function to compute <tr> element attributes from row key+  -> m (Dynamic t (Map k (El t, [v])))        -- ^ Map from row key to (El, list of widget return values) tableDynAttr klass cols dRows rowAttrs = elAttr "div" (Map.singleton "style" "zoom: 1; overflow: auto; background: white;") $ do     elAttr "table" (Map.singleton "class" klass) $ do       el "thead" $ el "tr" $ do@@ -770,7 +851,14 @@           elDynAttr' "tr" dAttrs $ mapM (\x -> el "td" $ snd x k r) cols)  --TODO preselect a tab on open-tabDisplay :: forall t m k. (MonadFix m, MonadWidget t m, Show k, Ord k) => String -> String -> Map k (String, m ()) -> m ()+-- | A widget to construct a tabbed view that shows only one of its child widgets at a time.+--   Creates a header bar containing a <ul> with one <li> per child; clicking a <li> displays+--   the corresponding child and hides all others.+tabDisplay :: forall t m k. (MonadFix m, MonadWidget t m, Show k, Ord k)+  => String               -- ^ Class applied to <ul> element+  -> String               -- ^ Class applied to currently active <li> element+  -> Map k (String, m ()) -- ^ Map from (arbitrary) key to (tab label, child widget)+  -> m () tabDisplay ulClass activeClass tabItems = do   rec dCurrentTab <- holdDyn Nothing (updated dTabClicks)       dTabClicks :: Dynamic t (Maybe k) <- elAttr "ul" (Map.singleton "class" ulClass) $ do@@ -782,7 +870,7 @@     _ <- listWithKey dTabs (\k dTab -> do       dAttrs <- mapDyn (\sel -> do         let t1 = listToMaybe $ Map.keys tabItems-        if sel == Just k || (sel == Nothing && t1 == Just k) then Map.empty else Map.singleton "style" "display:none;") dCurrentTab +        if sel == Just k || (sel == Nothing && t1 == Just k) then Map.empty else Map.singleton "style" "display:none;") dCurrentTab       elDynAttr "div" dAttrs $ dyn =<< mapDyn snd dTab)     return ()   where@@ -794,11 +882,11 @@         return $ fmap (const k) (_link_clicked a)  -- | Place an element into the DOM and wrap it with Reflex event handlers.  Note: undefined behavior may result if the element is placed multiple times, removed from the DOM after being placed, or in other situations.  Don't use this unless you understand the internals of MonadWidget.-unsafePlaceElement :: MonadWidget t m => HTMLElement -> m (El t)+unsafePlaceElement :: MonadWidget t m => Element -> m (El t) unsafePlaceElement e = do   p <- askParent-  _ <- liftIO $ nodeAppendChild p $ Just e-  wrapElement e+  _ <- appendChild p $ Just e+  wrapElement defaultDomEventHandler e  deriveGEq ''EventName deriveGCompare ''EventName
src/Reflex/Dom/Widget/Input.hs view
@@ -8,12 +8,13 @@  import Reflex import Reflex.Host.Class-import GHCJS.DOM.HTMLInputElement-import GHCJS.DOM.HTMLTextAreaElement-import GHCJS.DOM.Element-import GHCJS.DOM.HTMLSelectElement+import GHCJS.DOM.HTMLInputElement as Input+import GHCJS.DOM.HTMLTextAreaElement as TextArea+import GHCJS.DOM.Element hiding (error)+import GHCJS.DOM.HTMLSelectElement as Select import GHCJS.DOM.EventM-import GHCJS.DOM.UIEvent+import GHCJS.DOM.File+import qualified GHCJS.DOM.FileList as FileList import Data.Monoid import Data.Map as Map import Control.Lens@@ -35,11 +36,11 @@                }  data TextInputConfig t-    = TextInputConfig { _textInputConfig_inputType :: String-                      , _textInputConfig_initialValue :: String-                      , _textInputConfig_setValue :: Event t String-                      , _textInputConfig_attributes :: Dynamic t (Map String String)-                      }+   = TextInputConfig { _textInputConfig_inputType :: String+                     , _textInputConfig_initialValue :: String+                     , _textInputConfig_setValue :: Event t String+                     , _textInputConfig_attributes :: Dynamic t (Map String String)+                     }  instance Reflex t => Default (TextInputConfig t) where   def = TextInputConfig { _textInputConfig_inputType = "text"@@ -48,24 +49,25 @@                         , _textInputConfig_attributes = constDyn mempty                         } +-- | Create an input whose value is a string.  By default, the "type" attribute is set to "text", but it can be changed using the _textInputConfig_inputType field.  Note that only types for which the value is always a string will work - types whose value may be null will not work properly with this widget. textInput :: MonadWidget t m => TextInputConfig t -> m (TextInput t) textInput (TextInputConfig inputType initial eSetValue dAttrs) = do   e <- liftM castToHTMLInputElement $ buildEmptyElement "input" =<< mapDyn (Map.insert "type" inputType) dAttrs-  liftIO $ htmlInputElementSetValue e initial-  performEvent_ $ fmap (liftIO . htmlInputElementSetValue e) eSetValue-  eChange <- wrapDomEvent e elementOninput $ liftIO $ htmlInputElementGetValue e+  Input.setValue e $ Just initial+  performEvent_ $ fmap (Input.setValue e . Just) eSetValue+  eChange <- wrapDomEvent e (`on` input) $ fromMaybe "" <$> Input.getValue e   postGui <- askPostGui   runWithActions <- askRunWithActions   eChangeFocus <- newEventWithTrigger $ \eChangeFocusTrigger -> do-    unsubscribeOnblur <- liftIO $ elementOnblur e $ liftIO $ do-      postGui $ runWithActions [eChangeFocusTrigger :=> False]-    unsubscribeOnfocus <- liftIO $ elementOnfocus e $ liftIO $ do-      postGui $ runWithActions [eChangeFocusTrigger :=> True]+    unsubscribeOnblur <- on e blurEvent $ liftIO $ do+      postGui $ runWithActions [eChangeFocusTrigger :=> Identity False]+    unsubscribeOnfocus <- on e focusEvent $ liftIO $ do+      postGui $ runWithActions [eChangeFocusTrigger :=> Identity True]     return $ liftIO $ unsubscribeOnblur >> unsubscribeOnfocus   dFocus <- holdDyn False eChangeFocus-  eKeypress <- wrapDomEvent e elementOnkeypress getKeyEvent-  eKeydown <- wrapDomEvent e elementOnkeydown getKeyEvent-  eKeyup <- wrapDomEvent e elementOnkeyup getKeyEvent+  eKeypress <- wrapDomEvent e (`on` keyPress) getKeyEvent+  eKeydown <- wrapDomEvent e (`on` keyDown) getKeyEvent+  eKeyup <- wrapDomEvent e (`on` keyUp) getKeyEvent   dValue <- holdDyn initial $ leftmost [eSetValue, eChange]   return $ TextInput dValue eChange eKeypress eKeydown eKeyup dFocus e @@ -95,20 +97,20 @@ textArea :: MonadWidget t m => TextAreaConfig t -> m (TextArea t) textArea (TextAreaConfig initial eSet attrs) = do   e <- liftM castToHTMLTextAreaElement $ buildEmptyElement "textarea" attrs-  liftIO $ htmlTextAreaElementSetValue e initial+  TextArea.setValue e $ Just initial   postGui <- askPostGui   runWithActions <- askRunWithActions   eChangeFocus <- newEventWithTrigger $ \eChangeFocusTrigger -> do-    unsubscribeOnblur <- liftIO $ elementOnblur e $ liftIO $ do-      postGui $ runWithActions [eChangeFocusTrigger :=> False]-    unsubscribeOnfocus <- liftIO $ elementOnfocus e $ liftIO $ do-      postGui $ runWithActions [eChangeFocusTrigger :=> True]+    unsubscribeOnblur <- on e blurEvent $ liftIO $ do+      postGui $ runWithActions [eChangeFocusTrigger :=> Identity False]+    unsubscribeOnfocus <- on e focusEvent $ liftIO $ do+      postGui $ runWithActions [eChangeFocusTrigger :=> Identity True]     return $ liftIO $ unsubscribeOnblur >> unsubscribeOnfocus-  performEvent_ $ fmap (liftIO . htmlTextAreaElementSetValue e) eSet+  performEvent_ $ fmap (TextArea.setValue e . Just) eSet   f <- holdDyn False eChangeFocus-  ev <- wrapDomEvent e elementOninput $ liftIO $ htmlTextAreaElementGetValue e+  ev <- wrapDomEvent e (`on` input) $ fromMaybe "" <$> TextArea.getValue e   v <- holdDyn initial $ leftmost [eSet, ev]-  eKeypress <- wrapDomEvent e elementOnkeypress getKeyEvent+  eKeypress <- wrapDomEvent e (`on` keyPress) getKeyEvent   return $ TextArea v ev e f eKeypress  data CheckboxConfig t@@ -133,23 +135,46 @@ checkbox checked config = do   attrs <- mapDyn (\c -> Map.insert "type" "checkbox" $ (if checked then Map.insert "checked" "checked" else Map.delete "checked") c) (_checkboxConfig_attributes config)   e <- liftM castToHTMLInputElement $ buildEmptyElement "input" attrs-  eClick <- wrapDomEvent e elementOnclick $ liftIO $ htmlInputElementGetChecked e-  performEvent_ $ fmap (\v -> liftIO $ htmlInputElementSetChecked e $! v) $ _checkboxConfig_setValue config+  eClick <- wrapDomEvent e (`on` click) $ Input.getChecked e+  performEvent_ $ fmap (\v -> Input.setChecked e $! v) $ _checkboxConfig_setValue config   dValue <- holdDyn checked $ leftmost [_checkboxConfig_setValue config, eClick]   return $ Checkbox dValue eClick  checkboxView :: MonadWidget t m => Dynamic t (Map String String) -> Dynamic t Bool -> m (Event t Bool) checkboxView dAttrs dValue = do   e <- liftM castToHTMLInputElement $ buildEmptyElement "input" =<< mapDyn (Map.insert "type" "checkbox") dAttrs-  eClicked <- wrapDomEvent e elementOnclick $ do+  eClicked <- wrapDomEvent e (`on` click) $ do     preventDefault-    liftIO $ htmlInputElementGetChecked e+    Input.getChecked e   schedulePostBuild $ do     v <- sample $ current dValue-    when v $ liftIO $ htmlInputElementSetChecked e True-  performEvent_ $ fmap (\v -> liftIO $ htmlInputElementSetChecked e $! v) $ updated dValue+    when v $ Input.setChecked e True+  performEvent_ $ fmap (\v -> Input.setChecked e $! v) $ updated dValue   return eClicked +data FileInput t+   = FileInput { _fileInput_value :: Dynamic t [File]+               , _fileInput_element :: HTMLInputElement+               }++data FileInputConfig t+   = FileInputConfig { _fileInputConfig_attributes :: Dynamic t (Map String String)+                     }++instance Reflex t => Default (FileInputConfig t) where+  def = FileInputConfig { _fileInputConfig_attributes = constDyn mempty+                        }++fileInput :: MonadWidget t m => FileInputConfig t -> m (FileInput t)+fileInput (FileInputConfig dAttrs) = do+  e <- liftM castToHTMLInputElement $ buildEmptyElement "input" =<< mapDyn (Map.insert "type" "file") dAttrs+  eChange <- wrapDomEvent e (flip on change) $ do+    Just files <- getFiles e+    len <- FileList.getLength files+    mapM (liftM (fromMaybe (error "fileInput: fileListItem returned null")) . FileList.item files) $ init [0..len]+  dValue <- holdDyn [] eChange+  return $ FileInput dValue e+ data Dropdown t k     = Dropdown { _dropdown_value :: Dynamic t k                , _dropdown_change :: Event t k@@ -176,9 +201,9 @@     listWithKey optionsWithDefault $ \k v -> do       elAttr "option" ("value" =: show k <> if k == k0 then "selected" =: "selected" else mempty) $ dynText v   let e = castToHTMLSelectElement $ _el_element eRaw-  performEvent_ $ fmap (liftIO . htmlSelectElementSetValue e . show) setK-  eChange <- wrapDomEvent e elementOnchange $ do-    kStr <- liftIO $ htmlSelectElementGetValue e+  performEvent_ $ fmap (Select.setValue e . Just . show) setK+  eChange <- wrapDomEvent e (`on` change) $ do+    kStr <- fromMaybe "" <$> Select.getValue e     return $ readMay kStr   let readKey opts mk = fromMaybe k0 $ do         k <- mk@@ -198,10 +223,6 @@   , ''Checkbox   ] -class HasAttributes a where-  type Attrs a :: *-  attributes :: Lens' a (Attrs a)- instance HasAttributes (TextAreaConfig t) where   type Attrs (TextAreaConfig t) = Dynamic t (Map String String)   attributes = textAreaConfig_attributes@@ -250,6 +271,10 @@   type Value (TextInput t) = Dynamic t String   value = _textInput_value +instance HasValue (FileInput t) where+  type Value (FileInput t) = Dynamic t [File]+  value = _fileInput_value+ instance HasValue (Dropdown t k) where   type Value (Dropdown t k) = Dynamic t k   value = _dropdown_value@@ -295,4 +320,3 @@ instance HasStateModeWitness View where   stateModeWitness = ViewWitness -}-
src/Reflex/Dom/Widget/Lazy.hs view
@@ -6,16 +6,19 @@ import Reflex.Dom.Class import Reflex.Dom.Widget.Basic +import Control.Monad import Control.Monad.IO.Class import Data.Fixed import Data.Monoid import qualified Data.Map as Map import Data.Map (Map) import GHCJS.DOM.Element+import Data.Maybe+import Data.Int  -- |A list view for long lists. Creates a scrollable element and only renders child row elements near the current scroll position. virtualListWithSelection :: forall t m k v. (MonadWidget t m, Ord k)-  => Int -- ^ The height of the visible region in pixels+  => Dynamic t Int -- ^ The height of the visible region in pixels   -> Int -- ^ The height of each row in pixels   -> Dynamic t Int -- ^ The total number of items   -> Int -- ^ The index of the row to scroll to on initialization@@ -24,37 +27,39 @@   -> Dynamic t (Map String String) -- ^ The attributes of the list   -> String -- ^ The element tag for a row   -> Dynamic t (Map String String) -- ^ The attributes of each row-  -> (k -> Dynamic t v -> m ()) -- ^ The row child element builder+  -> (k -> Dynamic t (Maybe v) -> Dynamic t Bool -> m ()) -- ^ The row child element builder   -> Dynamic t (Map k v) -- ^ The 'Map' of items+  -> (Int -> k) -- ^ Index to Key function, used to determine position of Map elements   -> m (Dynamic t (Int, Int), Event t k) -- ^ A tuple containing: a 'Dynamic' of the index (based on the current scroll position) and number of items currently being rendered, and an 'Event' of the selected key-virtualListWithSelection heightPx rowPx maxIndex i0 setI listTag listAttrs rowTag rowAttrs itemBuilder items = do+virtualListWithSelection heightPx rowPx maxIndex i0 setI listTag listAttrs rowTag rowAttrs itemBuilder items indexToKey = do   totalHeightStyle <- mapDyn (toHeightStyle . (*) rowPx) maxIndex-  rec (container, itemList) <- elAttr "div" outerStyle $ elAttr' "div" containerStyle $ do+  containerStyle <- mapDyn toContainer heightPx+  viewportStyle <- mapDyn toViewport heightPx+  rec (container, sel) <- elDynAttr "div" containerStyle $ elDynAttr' "div" viewportStyle $ do         currentTop <- mapDyn (listWrapperStyle . fst) window-        (_, lis) <- elDynAttr "div" totalHeightStyle $ tagWrapper listTag listAttrs currentTop $ listWithKey itemsInWindow $ \k v -> do-            (li,_) <- tagWrapper rowTag rowAttrs (constDyn $ toHeightStyle rowPx) $ itemBuilder k v+        (_, lis) <- elDynAttr "div" totalHeightStyle $ tagWrapper listTag listAttrs currentTop $ selectViewListWithKey_ selected itemsInWindow $ \k v s -> do+            (li,_) <- tagWrapper rowTag rowAttrs (constDyn $ toHeightStyle rowPx) $ itemBuilder k v s             return $ fmap (const k) (domEvent Click li)         return lis-      scrollPosition <- holdDyn 0 $ domEvent Scroll container-      window <- mapDyn (findWindow heightPx rowPx) scrollPosition-      itemsInWindow <- combineDyn (\(_,(idx,num)) is -> Map.fromList $ take num $ drop idx $ Map.toList is) window items+      selected <- holdDyn (indexToKey i0) sel+      pb <- getPostBuild+      scrollPosition <- holdDyn 0 $ leftmost [ domEvent Scroll container+                                             , fmap (const (i0 * rowPx)) pb+                                             ]+      window <- combineDyn (\h -> findWindow h rowPx) heightPx scrollPosition+      itemsInWindow <- combineDyn (\(_,(idx,num)) is -> Map.fromList $ map (\i -> let ix = indexToKey i in (ix, Map.lookup ix is)) [idx .. idx + num]) window items   postBuild <- getPostBuild-  performEvent_ $ fmap (\i -> liftIO $ elementSetScrollTop (_el_element container) (i * rowPx)) $ leftmost [setI, fmap (const i0) postBuild]+  performEvent_ $ fmap (\i -> liftIO $ setScrollTop (_el_element container) (i * rowPx)) $ leftmost [setI, fmap (const i0) postBuild]   indexAndLength <- mapDyn snd window-  sel <- mapDyn (leftmost . Map.elems) itemList-  return (indexAndLength, switch $ current sel)+  return (indexAndLength, sel)   where     toStyleAttr m = "style" =: (Map.foldWithKey (\k v s -> k <> ":" <> v <> ";" <> s) "" m)-    outerStyle = toStyleAttr $ "position" =: "relative" <>-                               "height" =: (show heightPx <> "px")-    containerStyle = toStyleAttr $ "overflow" =: "auto" <>-                                   "position" =: "absolute" <>-                                   "left" =: "0" <>-                                   "right" =: "0" <>-                                   "height" =: (show heightPx <> "px")+    toViewport h = toStyleAttr $ "overflow" =: "auto" <> "position" =: "absolute" <>+                                 "left" =: "0" <> "right" =: "0" <> "height" =: (show h <> "px")+    toContainer h = toStyleAttr $ "position" =: "relative" <> "height" =: (show h <> "px")     listWrapperStyle t = toStyleAttr $ "position" =: "relative" <>                                        "top" =: (show t <> "px")-    toHeightStyle h = toStyleAttr ("height" =: (show h <> "px"))+    toHeightStyle h = toStyleAttr ("height" =: (show h <> "px") <> "overflow" =: "hidden")     tagWrapper elTag attrs attrsOverride c = do       attrs' <- combineDyn Map.union attrsOverride attrs       elDynAttr' elTag attrs' c@@ -65,3 +70,70 @@           preItems = min startingIndex numItems       in (topPx - preItems * sizeIncrement, (startingIndex - preItems, preItems + numItems * 2)) +virtualList :: forall t m k v a. (MonadWidget t m, Ord k)+  => Dynamic t Int -- ^ A 'Dynamic' of the visible region's height in pixels+  -> Int -- ^ The fixed height of each row in pixels+  -> Dynamic t Int -- ^ A 'Dynamic' of the total number of items+  -> Int -- ^ The index of the row to scroll to on initialization+  -> Event t Int -- ^ An 'Event' containing a row index. Used to scroll to the given index.+  -> (k -> Int) -- ^ Key to Index function, used to position items.+  -> Map k v -- ^ The initial 'Map' of items+  -> Event t (Map k (Maybe v)) -- ^ The update 'Event'. Nothing values are removed from the list and Just values are added or updated.+  -> (k -> v -> Event t v -> m a) -- ^ The row child element builder.+  -> m (Dynamic t (Int, Int), Dynamic t (Map k a)) -- ^ A tuple containing: a 'Dynamic' of the index (based on the current scroll position) and number of items currently being rendered, and the 'Dynamic' list result+virtualList heightPx rowPx maxIndex i0 setI keyToIndex items0 itemsUpdate itemBuilder = do+  virtualH <- mapDyn (mkVirtualHeight . (*) rowPx) maxIndex+  containerStyle <- mapDyn mkContainer heightPx+  viewportStyle <- mapDyn mkViewport heightPx+  pb <- getPostBuild+  rec (viewport, result) <- elDynAttr "div" containerStyle $ elDynAttr' "div" viewportStyle $ elDynAttr "div" virtualH $+        listWithKeyShallowDiff items0 itemsUpdate $ \k v e -> elAttr "div" (mkRow k) $ itemBuilder k v e+      scrollPosition <- holdDyn 0 $ leftmost [ domEvent Scroll viewport+                                             , fmap (const (i0 * rowPx)) pb+                                             ]+      window <- combineDyn (\h -> findWindow h rowPx) heightPx scrollPosition+  performEvent_ $ fmap (\i -> liftIO $ setScrollTop (_el_element viewport) (i * rowPx)) $ leftmost [setI, fmap (const i0) pb]+  return (nubDyn window, result)+  where+    toStyleAttr m = "style" =: (Map.foldWithKey (\k v s -> k <> ":" <> v <> ";" <> s) "" m)+    mkViewport h = toStyleAttr $ "overflow" =: "auto" <> "position" =: "absolute" <>+                                 "left" =: "0" <> "right" =: "0" <> "height" =: (show h <> "px")+    mkContainer h = toStyleAttr $ "position" =: "relative" <> "height" =: (show h <> "px")+    mkVirtualHeight h = let h' = h * rowPx+                        in toStyleAttr $ "height" =: (show h <> "px") <>+                                         "overflow" =: "hidden" <>+                                         "position" =: "relative"+    mkRow k = toStyleAttr $ "height" =: (show rowPx <> "px") <>+                            "top" =: ((<>"px") $ show $ keyToIndex k * rowPx) <>+                            "position" =: "absolute" <>+                            "width" =: "100%"+    findWindow windowSize sizeIncrement startingPosition =+      let (startingIndex, topOffsetPx) = startingPosition `divMod'` sizeIncrement+          numItems = (windowSize + sizeIncrement - 1) `div` sizeIncrement+      in (startingIndex, numItems)++virtualListBuffered+  :: (Ord k, MonadWidget t m)+  => Int+  -> Dynamic t Int+  -> Int+  -> Dynamic t Int+  -> Int+  -> Event t Int+  -> (k -> Int)+  -> Map k v+  -> Event t (Map k (Maybe v))+  -> (k -> v -> Event t v -> m a)+  -> m (Event t (Int, Int), Dynamic t (Map k a))+virtualListBuffered buffer heightPx rowPx maxIndex i0 setI keyToIndex items0 itemsUpdate itemBuilder = do+    (win, m) <- virtualList heightPx rowPx maxIndex i0 setI keyToIndex items0 itemsUpdate itemBuilder+    pb <- getPostBuild+    let extendWin o l = (max 0 (o - l * (buffer-1) `div` 2), l * buffer)+    rec let winHitEdge = fmapMaybe id $ attachWith (\(oldOffset, oldLimit) (winOffset, winLimit) ->+              if winOffset > oldOffset && winOffset + winLimit < oldOffset + oldLimit+                 then Nothing+                 else Just (extendWin winOffset winLimit)) (current winBuffered) (updated win)+        winBuffered <- holdDyn (0, 0) $ leftmost [ winHitEdge+                                                 , fmap (uncurry extendWin) $ tagDyn win pb+                                                 ]+    return (updated winBuffered, m)
+ src/Reflex/Dom/Widget/Resize.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE RecursiveDo #-}+module Reflex.Dom.Widget.Resize where++import Reflex+import Reflex.Dom.Class+import Reflex.Dom.Widget.Basic++import Control.Monad+import Control.Monad.IO.Class+import Data.Monoid+import GHCJS.DOM.Element hiding (reset)+import GHCJS.DOM.EventM (on)++-- | A widget that wraps the given widget in a div and fires an event when resized.+--   Adapted from github.com/marcj/css-element-queries+resizeDetector :: MonadWidget t m => m a -> m (Event t (), a)+resizeDetector = resizeDetectorWithStyle ""++resizeDetectorWithStyle :: MonadWidget t m+  => String -- ^ A css style string. Warning: It should not contain the "position" style attribute.+  -> m a -- ^ The embedded widget+  -> m (Event t (), a) -- ^ An 'Event' that fires on resize, and the result of the embedded widget+resizeDetectorWithStyle styleString w = do+  let childStyle = "position: absolute; left: 0; top: 0;"+      containerAttrs = "style" =: "position: absolute; left: 0; top: 0; right: 0; bottom: 0; overflow: scroll; z-index: -1; visibility: hidden;"+  (parent, (expand, expandChild, shrink, w')) <- elAttr' "div" ("style" =: ("position: relative;" <> styleString)) $ do+    w' <- w+    elAttr "div" containerAttrs $ do+      (expand, (expandChild, _)) <- elAttr' "div" containerAttrs $ elAttr' "div" ("style" =: childStyle) $ return ()+      (shrink, _) <- elAttr' "div" containerAttrs $ elAttr "div" ("style" =: (childStyle <> "width: 200%; height: 200%;")) $ return ()+      return (expand, expandChild, shrink, w')+  let reset = do+        let e = _el_element expand+            s = _el_element shrink+        eow <- getOffsetWidth e+        eoh <- getOffsetHeight e+        let ecw = eow + 10+            ech = eoh + 10+        setAttribute (_el_element expandChild) "style" (childStyle <> "width: " <> show ecw <> "px;" <> "height: " <> show ech <> "px;")+        esw <- getScrollWidth e+        setScrollLeft e esw+        esh <- getScrollHeight e+        setScrollTop e esh+        ssw <- getScrollWidth s+        setScrollLeft s ssw+        ssh <- getScrollHeight s+        setScrollTop s ssh+        lastWidth <- getOffsetWidth (_el_element parent)+        lastHeight <- getOffsetHeight (_el_element parent)+        return (Just lastWidth, Just lastHeight)+      resetIfChanged ds = do+        pow <- getOffsetWidth (_el_element parent)+        poh <- getOffsetHeight (_el_element parent)+        if ds == (Just pow, Just poh)+           then return Nothing+           else liftM Just reset+  pb <- getPostBuild+  expandScroll <- wrapDomEvent (_el_element expand) (`on` scroll) $ return ()+  shrinkScroll <- wrapDomEvent (_el_element shrink) (`on` scroll) $ return ()+  size0 <- performEvent $ fmap (const $ liftIO reset) pb+  rec resize <- performEventAsync $ fmap (\d cb -> liftIO $ cb =<< resetIfChanged d) $ tag (current dimensions) $ leftmost [expandScroll, shrinkScroll]+      dimensions <- holdDyn (Nothing, Nothing) $ leftmost [ size0, fmapMaybe id resize ]+  return (fmap (const ()) $ fmapMaybe id resize, w')
src/Reflex/Dom/Xhr.hs view
@@ -1,7 +1,27 @@+{-# LANGUAGE DeriveDataTypeable #-}+ module Reflex.Dom.Xhr-  ( module Reflex.Dom.Xhr-  , XMLHttpRequest-  , responseTextToText+  ( XMLHttpRequest+  , XhrRequest(..)+  , XhrRequestConfig(..)+  , XhrResponse(..)+  , XhrResponseBody(..)+  , XhrResponseType(..)+  , XhrException(..)+  , _xhrResponse_body+  , xhrResponse_body+  , xhrRequest+  , newXMLHttpRequest+  , newXMLHttpRequestWithError+  , performRequestAsync+  , performRequestAsyncWithError+  , performRequestsAsync+  , performRequestsAsyncWithError+  , getAndDecode+  , postJson+  , getMay+  , decodeText+  , decodeXhrResponse   , xmlHttpRequestGetReadyState   , xmlHttpRequestGetResponseText   , xmlHttpRequestGetStatus@@ -16,10 +36,14 @@ where  import Control.Concurrent+import Control.Exception (catch) import Control.Lens import Control.Monad hiding (forM) import Control.Monad.IO.Class import Data.Aeson+import Data.Aeson.Encode+import qualified Data.Text.Lazy as LT+import qualified Data.Text.Lazy.Builder as B import qualified Data.ByteString.Lazy as BL import Data.Default import Data.Map (Map)@@ -30,7 +54,9 @@ import Data.Traversable import Reflex import Reflex.Dom.Class+import Reflex.Dom.Xhr.Exception import Reflex.Dom.Xhr.Foreign+import Reflex.Dom.Xhr.ResponseType import Data.Typeable  data XhrRequest@@ -44,16 +70,27 @@    = XhrRequestConfig { _xhrRequestConfig_headers :: Map String String                       , _xhrRequestConfig_user :: Maybe String                       , _xhrRequestConfig_password :: Maybe String-                      , _xhrRequestConfig_responseType :: Maybe String+                      , _xhrRequestConfig_responseType :: Maybe XhrResponseType                       , _xhrRequestConfig_sendData :: Maybe String                       }    deriving (Show, Read, Eq, Ord, Typeable)  data XhrResponse-   = XhrResponse { _xhrResponse_body :: Maybe Text+   = XhrResponse { _xhrResponse_status :: Word+                 , _xhrResponse_statusText :: Text+                 , _xhrResponse_response :: Maybe XhrResponseBody+                 , _xhrResponse_responseText :: Maybe Text                  }-   deriving (Show, Read, Eq, Ord, Typeable)+   deriving (Typeable) +{-# DEPRECATED _xhrResponse_body "Use _xhrResponse_response or _xhrResponse_responseText instead." #-}+_xhrResponse_body :: XhrResponse -> Maybe Text+_xhrResponse_body = _xhrResponse_responseText++{-# DEPRECATED xhrResponse_body "Use xhrResponse_response or xhrResponse_responseText instead." #-}+xhrResponse_body :: Lens XhrResponse XhrResponse (Maybe Text) (Maybe Text)+xhrResponse_body = lens _xhrResponse_responseText (\r t -> r { _xhrResponse_responseText = t })+ instance Default XhrRequestConfig where   def = XhrRequestConfig { _xhrRequestConfig_headers = Map.empty                          , _xhrRequestConfig_user = Nothing@@ -62,16 +99,30 @@                          , _xhrRequestConfig_sendData  = Nothing                          } +-- | Construct a request object from method, URL, and config record. xhrRequest :: String -> String -> XhrRequestConfig -> XhrRequest xhrRequest = XhrRequest -newXMLHttpRequest :: (HasWebView m, MonadIO m, HasPostGui t h m) => XhrRequest -> (XhrResponse -> h ()) -> m XMLHttpRequest-newXMLHttpRequest req cb = do+-- | Make a new asyncronous XHR request. This does not block (it forks),+-- and returns an XHR object immediately (which you can use to abort+-- the XHR connection), and will pass an exception ('XhrException') to the+-- continuation if the connection cannot be made (or is aborted).+newXMLHttpRequestWithError+    :: (HasWebView m, MonadIO m, HasPostGui t h m)+    => XhrRequest+    -- ^ The request to make.+    -> (Either XhrException XhrResponse -> h ())+    -- ^ A continuation to be called once a response comes back, or in+    -- case of error.+    -> m XMLHttpRequest+    -- ^ The XHR request, which could for example be aborted.+newXMLHttpRequestWithError req cb = do   wv <- askWebView   postGui <- askPostGui-  liftIO $ do-    xhr <- xmlHttpRequestNew wv+  xhr <- liftIO $ xmlHttpRequestNew wv+  void $ liftIO $ forkIO $ flip catch (postGui . cb . Left) $ void $ do     let c = _xhrRequest_config req+        rt = _xhrRequestConfig_responseType c     xmlHttpRequestOpen       xhr       (_xhrRequest_method req)@@ -80,37 +131,90 @@       (fromMaybe "" $ _xhrRequestConfig_user c)       (fromMaybe "" $ _xhrRequestConfig_password c)     iforM_ (_xhrRequestConfig_headers c) $ xmlHttpRequestSetRequestHeader xhr-    maybe (return ()) (xmlHttpRequestSetResponseType xhr . toResponseType) (_xhrRequestConfig_responseType c)+    maybe (return ()) (xmlHttpRequestSetResponseType xhr . fromResponseType) rt     _ <- xmlHttpRequestOnreadystatechange xhr $ do       readyState <- liftIO $ xmlHttpRequestGetReadyState xhr+      status <- liftIO $ xmlHttpRequestGetStatus xhr+      statusText <- liftIO $ xmlHttpRequestGetStatusText xhr       if readyState == 4           then do-            r <- liftIO $ xmlHttpRequestGetResponseText xhr-            _ <- liftIO $ postGui $ cb $ XhrResponse $ responseTextToText r+            t <- if rt == Just XhrResponseType_Text || rt == Nothing+                   then liftIO $ xmlHttpRequestGetResponseText xhr+                   else  return Nothing+            r <- liftIO $ xmlHttpRequestGetResponse xhr+            _ <- liftIO $ postGui $ cb $ Right $+                   XhrResponse { _xhrResponse_status = status+                               , _xhrResponse_statusText = statusText+                               , _xhrResponse_response = r+                               , _xhrResponse_responseText = t+                               }             return ()           else return ()     _ <- xmlHttpRequestSend xhr (_xhrRequestConfig_sendData c)-    return xhr+    return ()+  return xhr -performRequestAsync :: (MonadWidget t m) => Event t XhrRequest -> m (Event t XhrResponse)-performRequestAsync req = performEventAsync $ ffor req $ \r cb -> do-  _ <- newXMLHttpRequest r $ liftIO . cb-  return ()+newXMLHttpRequest :: (HasWebView m, MonadIO m, HasPostGui t h m) => XhrRequest -> (XhrResponse -> h ()) -> m XMLHttpRequest+newXMLHttpRequest req cb = newXMLHttpRequestWithError req $ mapM_ cb +-- | Given Event of requests, issue them when the Event fires.+-- Returns Event of corresponding responses.+--+-- The request is processed asynchronously, therefore handling does+-- not block or cause a delay while creating the connection.+performRequestAsyncWithError+    :: MonadWidget t m+    => Event t XhrRequest -> m (Event t (Either XhrException XhrResponse))+performRequestAsyncWithError = performRequestAsync' newXMLHttpRequestWithError++performRequestAsync :: MonadWidget t m => Event t XhrRequest -> m (Event t XhrResponse)+performRequestAsync = performRequestAsync' newXMLHttpRequest++performRequestAsync' :: (MonadWidget t m, MonadIO h) => (XhrRequest -> (a -> h ()) -> WidgetHost m XMLHttpRequest) -> Event t XhrRequest -> m (Event t a)+performRequestAsync' newXhr req = performEventAsync $ ffor req $ \r cb -> void $ newXhr r $ liftIO . cb++-- | 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.+--+-- The requests are processed asynchronously, therefore handling does+-- not block or cause a delay while creating the connection.+--+-- Order of request execution and completion is not guaranteed, but+-- order of creation and the collection result is preserved.+performRequestsAsyncWithError+    :: (Traversable f, MonadWidget t m)+    => Event t (f XhrRequest) -> m (Event t (f (Either XhrException XhrResponse)))+performRequestsAsyncWithError = performRequestsAsync' newXMLHttpRequestWithError++ performRequestsAsync :: (Traversable f, MonadWidget t m) => Event t (f XhrRequest) -> m (Event t (f XhrResponse))-performRequestsAsync req = performEventAsync $ ffor req $ \rs cb -> do+performRequestsAsync = performRequestsAsync' newXMLHttpRequest++performRequestsAsync' :: (MonadWidget t m, MonadIO h, Traversable f) => (XhrRequest -> (a -> h ()) -> WidgetHost m XMLHttpRequest) -> Event t (f XhrRequest) -> m (Event t (f a))+performRequestsAsync' newXhr req = performEventAsync $ ffor req $ \rs cb -> do   resps <- forM rs $ \r -> do     resp <- liftIO newEmptyMVar-    _ <- newXMLHttpRequest r $ liftIO . putMVar resp+    _ <- newXhr r $ liftIO . putMVar resp     return resp   _ <- liftIO $ forkIO $ cb =<< forM resps takeMVar   return () +-- | Simplified interface to "GET" URLs and return decoded results. getAndDecode :: (FromJSON a, MonadWidget t m) => Event t String -> m (Event t (Maybe a)) getAndDecode url = do   r <- performRequestAsync $ fmap (\x -> XhrRequest "GET" x def) url   return $ fmap decodeXhrResponse r +-- | Create a "POST" request from an URL and thing with a JSON representation+postJson :: (ToJSON a) => String -> a -> XhrRequest+postJson url a =+  XhrRequest "POST" url $ def { _xhrRequestConfig_headers = headerUrlEnc+                              , _xhrRequestConfig_sendData = Just body+                              }+  where headerUrlEnc = "Content-type" =: "application/json"+        body = LT.unpack $ B.toLazyText $ encodeToTextBuilder $ toJSON a+ getMay :: MonadWidget t m => (Event t a -> m (Event t b)) -> Event t (Maybe a) -> m (Event t (Maybe b)) getMay f e = do     e' <- f (fmapMaybe id e)@@ -119,6 +223,7 @@ decodeText :: FromJSON a => Text -> Maybe a decodeText = decode . BL.fromStrict . encodeUtf8 +-- | Convenience function to decode JSON-encoded responses. decodeXhrResponse :: FromJSON a => XhrResponse -> Maybe a-decodeXhrResponse = join . fmap decodeText . _xhrResponse_body+decodeXhrResponse = join . fmap decodeText . _xhrResponse_responseText
+ src/Reflex/Dom/Xhr/Exception.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE DeriveDataTypeable #-}++module Reflex.Dom.Xhr.Exception where++import Data.Typeable+import Control.Exception (Exception(..))++data XhrException = XhrException_Error+                  | XhrException_Aborted+     deriving (Show, Read, Eq, Ord, Typeable)++instance Exception XhrException
+ src/Reflex/Dom/Xhr/ResponseType.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE DeriveDataTypeable #-}++module Reflex.Dom.Xhr.ResponseType where++import Data.Typeable+import Data.Text (Text)+import GHCJS.DOM.Blob (Blob)+import Data.ByteString (ByteString)++data XhrResponseType = XhrResponseType_Default+                     | XhrResponseType_ArrayBuffer+                     | XhrResponseType_Blob+                     | XhrResponseType_Text+   deriving (Show, Read, Eq, Ord, Typeable)++data XhrResponseBody = XhrResponseBody_Default Text+                     | XhrResponseBody_Text Text+                     | XhrResponseBody_Blob Blob+                     | XhrResponseBody_ArrayBuffer ByteString+    deriving (Eq)+