git.iko.soy/reflex-dom
on develop help sign in
Merge remote-tracking branch 'origin/develop' into HEAD
af398f1Cale Gibbard
README.md+1−1
compare with develop
unifiedsplit
@@ -3,7 +3,7 @@
3
3
4Reflex-DOM is a framework for building web applications in Haskell, based on the [Functional Reactive Programming](https://wiki.haskell.org/Functional_Reactive_Programming) library [Reflex](https://github.com/ryantrinkle/reflex).
4Reflex-DOM is a framework for building web applications in Haskell, based on the [Functional Reactive Programming](https://wiki.haskell.org/Functional_Reactive_Programming) library [Reflex](https://github.com/ryantrinkle/reflex).
5
5
6−Comprehensive documentation is still a work in progress, but a [demo](https://github.com/ryantrinkle/try-reflex) is available and an introductory talk is available at [Part 1](https://www.youtube.com/watch?v=mYvkcskJbc4) / [Part 2](https://www.youtube.com/watch?v=3qfc9XFVo2c).
6+Comprehensive documentation is still a work in progress, but a [demo](https://github.com/ryantrinkle/try-reflex) is available and an introductory talk is available at [Part 1](https://www.youtube.com/watch?v=mYvkcskJbc4) / [Part 2](https://www.youtube.com/watch?v=3qfc9XFVo2c) ([Slides](https://obsidian.systems/reflex-nyhug/)).
7
7
8### Additional resources
8### Additional resources
9[try reflex](https://github.com/ryantrinkle/try-reflex)
9[try reflex](https://github.com/ryantrinkle/try-reflex)
reflex-dom.cabal+8−5
@@ -27,11 +27,11 @@ library
27 semigroups == 0.16.*,
27 semigroups == 0.16.*,
28 mtl >= 2.1 && < 2.3,
28 mtl >= 2.1 && < 2.3,
29 containers == 0.5.*,
29 containers == 0.5.*,
30− these >= 0.4,
30+ these >= 0.4 && < 0.7,
31 ref-tf == 0.4.*,
31 ref-tf == 0.4.*,
32 random == 1.1.*,
32 random == 1.1.*,
33 transformers == 0.3.* || == 0.4.*,
33 transformers == 0.3.* || == 0.4.*,
34− lens >= 4.7 && < 4.10,
34+ lens >= 4.7 && < 4.14,
35 ghcjs-dom >= 0.1.1.3 && < 0.2,
35 ghcjs-dom >= 0.1.1.3 && < 0.2,
36 safe == 0.3.*,
36 safe == 0.3.*,
37 text == 1.2.*,
37 text == 1.2.*,
@@ -42,8 +42,8 @@ library
42 exception-transformers == 0.4.*,
42 exception-transformers == 0.4.*,
43 directory == 1.2.*,
43 directory == 1.2.*,
44 dependent-sum-template >= 0.0.0.4 && < 0.1,
44 dependent-sum-template >= 0.0.0.4 && < 0.1,
45+ zenc == 0.1.*,
45− bifunctors == 4.2.*,
46+ bifunctors >= 4.2 && < 5.1
46− zenc == 0.1.*
47
47
48 if impl(ghcjs)
48 if impl(ghcjs)
49 hs-source-dirs: src-ghcjs
49 hs-source-dirs: src-ghcjs
@@ -65,15 +65,18 @@ library
65 Reflex.Dom
65 Reflex.Dom
66 Reflex.Dom.Class
66 Reflex.Dom.Class
67 Reflex.Dom.Internal
67 Reflex.Dom.Internal
68+ Reflex.Dom.Time
69+ Reflex.Dom.WebSocket
68 Reflex.Dom.Widget
70 Reflex.Dom.Widget
69 Reflex.Dom.Widget.Basic
71 Reflex.Dom.Widget.Basic
70 Reflex.Dom.Widget.Input
72 Reflex.Dom.Widget.Input
71 Reflex.Dom.Widget.Lazy
73 Reflex.Dom.Widget.Lazy
74+ Reflex.Dom.Widget.Resize
72 Reflex.Dom.Xhr
75 Reflex.Dom.Xhr
73− Reflex.Dom.Time
74 Foreign.JavaScript.TH
76 Foreign.JavaScript.TH
75 other-modules:
77 other-modules:
76 Reflex.Dom.Internal.Foreign
78 Reflex.Dom.Internal.Foreign
79+ Reflex.Dom.WebSocket.Foreign
77 Reflex.Dom.Xhr.Foreign
80 Reflex.Dom.Xhr.Foreign
78
81
79 other-extensions: TemplateHaskell
82 other-extensions: TemplateHaskell
src-ghc/Reflex/Dom/Internal/Foreign.hs+32
@@ -1,12 +1,18 @@
1{-# LANGUAGE ForeignFunctionInterface #-}
1{-# LANGUAGE ForeignFunctionInterface #-}
2module Reflex.Dom.Internal.Foreign where
2module Reflex.Dom.Internal.Foreign where
3
3
4+import Control.Lens hiding (set)
4import GHCJS.DOM hiding (runWebGUI)
5import GHCJS.DOM hiding (runWebGUI)
5import Control.Concurrent
6import Control.Concurrent
6import Control.Monad.State.Strict hiding (mapM, mapM_, forM, forM_, sequence, sequence_, get)
7import Control.Monad.State.Strict hiding (mapM, mapM_, forM, forM_, sequence, sequence_, get)
8+import Foreign.Ptr
7import GHCJS.DOM.Navigator
9import GHCJS.DOM.Navigator
8import GHCJS.DOM.DOMWindow
10import GHCJS.DOM.DOMWindow
9import Graphics.UI.Gtk hiding (Widget)
11import Graphics.UI.Gtk hiding (Widget)
12+import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSBase
13+import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSObjectRef
14+import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSStringRef
15+import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSValueRef
10import Graphics.UI.Gtk.WebKit.WebView
16import Graphics.UI.Gtk.WebKit.WebView
11import Graphics.UI.Gtk.WebKit.Types hiding (Event, Widget, unWidget)
17import Graphics.UI.Gtk.WebKit.Types hiding (Event, Widget, unWidget)
12import Graphics.UI.Gtk.WebKit.WebSettings
18import Graphics.UI.Gtk.WebKit.WebSettings
@@ -14,6 +20,7 @@ import Graphics.UI.Gtk.WebKit.WebFrame
14import Graphics.UI.Gtk.WebKit.WebInspector
20import Graphics.UI.Gtk.WebKit.WebInspector
15import Data.List
21import Data.List
16import System.Directory
22import System.Directory
23+import System.Glib.FFI hiding (void)
17
24
18makeDefaultWebView :: String -> (WebView -> IO ()) -> IO ()
25makeDefaultWebView :: String -> (WebView -> IO ()) -> IO ()
19makeDefaultWebView userAgentKey main = do
26makeDefaultWebView userAgentKey main = do
@@ -67,3 +74,28 @@ runWebGUI' userAgentKey main = do
67 unless ((" " ++ userAgentKey) `isSuffixOf` agent) $ main (castToWebView window)
74 unless ((" " ++ userAgentKey) `isSuffixOf` agent) $ main (castToWebView window)
68 Nothing -> do
75 Nothing -> do
69 makeDefaultWebView userAgentKey main
76 makeDefaultWebView userAgentKey main
77+
78+foreign import ccall "wrapper"
79+ wrapper :: JSObjectCallAsFunctionCallback' -> IO JSObjectCallAsFunctionCallback
80+
81+toJSObject :: JSContextRef -> [Ptr OpaqueJSValue] -> IO JSObjectRef
82+toJSObject ctx args = do
83+ o <- jsobjectmake ctx nullPtr nullPtr
84+ iforM_ args $ \n a -> do
85+ prop <- jsstringcreatewithutf8cstring $ show n
86+ jsobjectsetproperty ctx o prop a 1 nullPtr
87+ return o
88+
89+fromJSStringMaybe :: JSContextRef -> JSValueRef -> IO (Maybe String)
90+fromJSStringMaybe c t = do
91+ isNull <- jsvalueisnull c t
92+ case isNull of
93+ True -> return Nothing
94+ False -> do
95+ j <- jsvaluetostringcopy c t nullPtr
96+ l <- jsstringgetmaximumutf8cstringsize j
97+ s <- allocaBytes (fromIntegral l) $ \ps -> do
98+ _ <- jsstringgetutf8cstring'_ j ps (fromIntegral l)
99+ peekCString ps
100+ return $ Just s
101+
src-ghc/Reflex/Dom/WebSocket/Foreign.hsnew file+84
@@ -0,0 +1,84 @@
1+{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI, CPP, TemplateHaskell, NoMonomorphismRestriction, EmptyDataDecls, RankNTypes, GADTs, RecursiveDo, ScopedTypeVariables, FlexibleInstances, MultiParamTypeClasses, TypeFamilies, FlexibleContexts, DeriveDataTypeable, GeneralizedNewtypeDeriving, StandaloneDeriving, ConstraintKinds, UndecidableInstances, PolyKinds, AllowAmbiguousTypes #-}
2+
3+module Reflex.Dom.WebSocket.Foreign where
4+
5+import Prelude hiding (div, span, mapM, mapM_, concat, concatMap, all, sequence)
6+
7+import Control.Exception
8+import Control.Monad.State
9+import Data.ByteString (ByteString)
10+import Data.Text.Encoding
11+import Foreign.Marshal hiding (void)
12+import Foreign.Ptr
13+import Foreign.Storable
14+import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSBase
15+import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSObjectRef
16+import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSStringRef
17+import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSValueRef
18+import Graphics.UI.Gtk.WebKit.JavaScriptCore.WebFrame
19+import Graphics.UI.Gtk.WebKit.WebView
20+import qualified Data.ByteString as BS
21+import qualified Data.Text as T
22+
23+import Reflex.Dom.Internal.Foreign
24+
25+data JSWebSocket = JSWebSocket { wsValue :: JSValueRef
26+ , wsContext :: JSContextRef
27+ }
28+
29+getLocationHost :: WebView -> IO String
30+getLocationHost wv = do
31+ c <- webFrameGetGlobalContext =<< webViewGetMainFrame wv
32+ script <- jsstringcreatewithutf8cstring "location.host"
33+ lh <- jsevaluatescript c script nullPtr nullPtr 1 nullPtr
34+ lh' <- fromJSStringMaybe c lh
35+ return $ maybe "" id lh'
36+
37+getLocationProtocol :: WebView -> IO String
38+getLocationProtocol wv = do
39+ c <- webFrameGetGlobalContext =<< webViewGetMainFrame wv
40+ script <- jsstringcreatewithutf8cstring "location.protocol"
41+ lp <- jsevaluatescript c script nullPtr nullPtr 1 nullPtr
42+ lp' <- fromJSStringMaybe c lp
43+ return $ maybe "" id lp'
44+
45+newWebSocket :: WebView -> String -> (ByteString -> IO ()) -> IO () -> IO JSWebSocket
46+newWebSocket wv url onMessage onClose = do
47+ c <- webFrameGetGlobalContext =<< webViewGetMainFrame wv
48+ url' <- jsvaluemakestring c =<< jsstringcreatewithutf8cstring url
49+ newWSArgs <- toJSObject c [url']
50+ newWS <- jsstringcreatewithutf8cstring "(function(that) { var ws = new WebSocket(that[0]); ws['binaryType'] = 'arraybuffer'; return ws; })(this)"
51+ ws <- jsevaluatescript c newWS newWSArgs nullPtr 1 nullPtr
52+ onMessage' <- wrapper $ \_ _ _ _ args _ -> do
53+ e <- peekElemOff args 0
54+ dataProp <- jsstringcreatewithutf8cstring "data"
55+ msg <- jsobjectgetproperty c e dataProp nullPtr
56+ msg' <- fromJSStringMaybe c msg
57+ case msg' of
58+ Nothing -> return ()
59+ Just m -> onMessage $ encodeUtf8 $ T.pack m
60+ jsvaluemakeundefined c
61+ onMessageCb <- jsobjectmakefunctionwithcallback c nullPtr onMessage'
62+ onClose' <- wrapper $ \_ _ _ _ _ _ -> do
63+ onClose
64+ jsvaluemakeundefined c
65+ onCloseCb <- jsobjectmakefunctionwithcallback c nullPtr onClose'
66+ o <- toJSObject c [ws, onMessageCb, onCloseCb]
67+ addCbs <- jsstringcreatewithutf8cstring "this[0]['onmessage'] = this[1]; this[0]['onclose'] = this[2];"
68+ _ <- jsevaluatescript c addCbs o nullPtr 1 nullPtr
69+ return $ JSWebSocket ws c
70+
71+webSocketSend :: JSWebSocket -> ByteString -> IO ()
72+webSocketSend (JSWebSocket ws c) bs = do
73+ elems <- forM (BS.unpack bs) $ \x -> jsvaluemakenumber c $ fromIntegral x
74+ let numElems = length elems
75+ bs' <- bracket (mallocArray numElems) free $ \elemsArr -> do
76+ pokeArray elemsArr elems
77+ a <- jsobjectmakearray c (fromIntegral numElems) elemsArr nullPtr
78+ newUint8Array <- jsstringcreatewithutf8cstring "new Uint8Array(this)"
79+ jsevaluatescript c newUint8Array a nullPtr 1 nullPtr
80+ send <- jsstringcreatewithutf8cstring "this[0]['send'](String['fromCharCode']['apply'](null, this[1]))"
81+ sendArgs <- toJSObject c [ws, bs']
82+ _ <- jsevaluatescript c send sendArgs nullPtr 1 nullPtr
83+ return ()
84+
src-ghc/Reflex/Dom/Xhr/Foreign.hs+5−11
@@ -13,23 +13,20 @@ import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSValueRef
13import Graphics.UI.Gtk.WebKit.JavaScriptCore.WebFrame
13import Graphics.UI.Gtk.WebKit.JavaScriptCore.WebFrame
14import GHCJS.DOM.File
14import GHCJS.DOM.File
15
15
16+import Reflex.Dom.Internal.Foreign
17+
16data XMLHttpRequest
18data XMLHttpRequest
17 = XMLHttpRequest { xhrValue :: JSValueRef
19 = XMLHttpRequest { xhrValue :: JSValueRef
18 , xhrContext :: JSContextRef --TODO: Get rid of this
20 , xhrContext :: JSContextRef --TODO: Get rid of this
19 }
21 }
20 deriving (Eq, Ord)
22 deriving (Eq, Ord)
21
23
22−toJSObject :: JSContextRef -> [Ptr OpaqueJSValue] -> IO JSObjectRef
23−toJSObject ctx args = do
24− o <- jsobjectmake ctx nullPtr nullPtr
25− iforM_ args $ \n a -> do
26− prop <- jsstringcreatewithutf8cstring $ show n
27− jsobjectsetproperty ctx o prop a 1 nullPtr
28− return o
29−
30responseTextToText :: Maybe String -> Maybe Text
24responseTextToText :: Maybe String -> Maybe Text
31responseTextToText = fmap T.pack
25responseTextToText = fmap T.pack
32
26
27+statusTextToText :: String -> Text
28+statusTextToText = T.pack
29+
33stringToJSValue :: JSContextRef -> String -> IO JSValueRef
30stringToJSValue :: JSContextRef -> String -> IO JSValueRef
34stringToJSValue ctx s = jsvaluemakestring ctx =<< jsstringcreatewithutf8cstring s
31stringToJSValue ctx s = jsvaluemakestring ctx =<< jsstringcreatewithutf8cstring s
35
32
@@ -58,9 +55,6 @@ xmlHttpRequestOpen xhr method url async user password = do
58 _ <- jsevaluatescript c script o nullPtr 1 nullPtr
55 _ <- jsevaluatescript c script o nullPtr 1 nullPtr
59 return ()
56 return ()
60
57
61−foreign import ccall "wrapper"
62− wrapper :: JSObjectCallAsFunctionCallback' -> IO JSObjectCallAsFunctionCallback
63−
64xmlHttpRequestOnreadystatechange :: XMLHttpRequest -> IO () -> IO ()
58xmlHttpRequestOnreadystatechange :: XMLHttpRequest -> IO () -> IO ()
65xmlHttpRequestOnreadystatechange xhr userCallback = do
59xmlHttpRequestOnreadystatechange xhr userCallback = do
66 let c = xhrContext xhr
60 let c = xhrContext xhr
src-ghcjs/Reflex/Dom/WebSocket/Foreign.hsnew file+49
@@ -0,0 +1,49 @@
1+{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI, CPP, TemplateHaskell, NoMonomorphismRestriction, EmptyDataDecls, RankNTypes, GADTs, RecursiveDo, ScopedTypeVariables, FlexibleInstances, MultiParamTypeClasses, TypeFamilies, FlexibleContexts, DeriveDataTypeable, GeneralizedNewtypeDeriving, StandaloneDeriving, ConstraintKinds, UndecidableInstances, PolyKinds, AllowAmbiguousTypes #-}
2+
3+module Reflex.Dom.WebSocket.Foreign where
4+
5+import Prelude hiding (div, span, mapM, mapM_, concat, concatMap, all, sequence)
6+
7+import Control.Monad hiding (forM, forM_, mapM, mapM_, sequence)
8+import Data.ByteString (ByteString)
9+import Data.Text.Encoding
10+import qualified Data.ByteString as BS
11+import Foreign.Ptr
12+import GHCJS.Foreign
13+import GHCJS.Types
14+
15+#define JS(name, js, type) foreign import javascript unsafe js name :: type
16+
17+newtype JSWebSocket = JSWebSocket { unWebSocket :: JSRef JSWebSocket }
18+
19+data JSByteArray
20+JS(extractByteArray, "new Uint8Array($1_1.buf, $1_2, $2)", Ptr a -> Int -> IO (JSRef JSByteArray))
21+
22+JS(newWebSocket_, "(function() { var ws = new WebSocket($1); ws['binaryType'] = 'arraybuffer'; ws['onmessage'] = function(e){ $2(e['data']); }; ws['onclose'] = function(e){ $3(); }; return ws; })()", JSString -> JSFun (JSString -> IO ()) -> JSFun (IO ()) -> IO (JSRef JSWebSocket))
23+
24+JS(webSocketSend_, "$1['send'](String.fromCharCode.apply(null, $2))", JSRef JSWebSocket -> JSRef JSByteArray -> IO ())
25+
26+webSocketSend :: JSWebSocket -> ByteString -> IO ()
27+webSocketSend ws bs = BS.useAsCString bs $ \cStr -> do
28+ ba <- extractByteArray cStr $ BS.length bs
29+ webSocketSend_ (unWebSocket ws) ba
30+
31+JS(getLocationHost_, "location.host", IO JSString)
32+
33+getLocationHost :: FromJSString r => a -> IO r
34+getLocationHost _ = liftM fromJSString getLocationHost_
35+
36+JS(getLocationProtocol_, "location.protocol", IO JSString)
37+
38+getLocationProtocol :: FromJSString r => a -> IO r
39+getLocationProtocol _ = liftM fromJSString getLocationProtocol_
40+
41+newWebSocket :: a -> String -> (ByteString -> IO ()) -> IO () -> IO JSWebSocket
42+newWebSocket _ url onMessage onClose = do
43+ onMessageFun <- syncCallback1 AlwaysRetain True $ onMessage <=< return . encodeUtf8 . fromJSString
44+ rec onCloseFun <- syncCallback AlwaysRetain True $ do
45+ release onMessageFun
46+ release onCloseFun
47+ onClose
48+ liftM JSWebSocket $ newWebSocket_ (toJSString url) onMessageFun onCloseFun
49+
src-ghcjs/Reflex/Dom/Xhr/Foreign.hs+3
@@ -333,6 +333,9 @@ xmlHttpRequestGetResponseText self
333responseTextToText :: (Maybe JSString) -> Maybe Text
333responseTextToText :: (Maybe JSString) -> Maybe Text
334responseTextToText r = fmap (T.pack . fromJSString) r
334responseTextToText r = fmap (T.pack . fromJSString) r
335
335
336+statusTextToText :: Text -> Text
337+statusTextToText = id
338+
336foreign import javascript unsafe "$1[\"responseXML\"]"
339foreign import javascript unsafe "$1[\"responseXML\"]"
337 ghcjs_dom_xml_http_request_get_response_xml ::
340 ghcjs_dom_xml_http_request_get_response_xml ::
338 JSRef XMLHttpRequest -> IO (JSRef Document)
341 JSRef XMLHttpRequest -> IO (JSRef Document)
src/Reflex/Dom.hs+2
@@ -4,6 +4,7 @@ module Reflex.Dom ( module Reflex
4 , module Reflex.Dom.Widget
4 , module Reflex.Dom.Widget
5 , module Reflex.Dom.Xhr
5 , module Reflex.Dom.Xhr
6 , module Reflex.Dom.Time
6 , module Reflex.Dom.Time
7+ , module Reflex.Dom.WebSocket
7 ) where
8 ) where
8
9
9import Reflex
10import Reflex
@@ -12,3 +13,4 @@ import Reflex.Dom.Internal
12import Reflex.Dom.Widget
13import Reflex.Dom.Widget
13import Reflex.Dom.Xhr
14import Reflex.Dom.Xhr
14import Reflex.Dom.Time
15import Reflex.Dom.Time
16+import Reflex.Dom.WebSocket
src/Reflex/Dom/Time.hs+16−5
@@ -41,11 +41,22 @@ tickLossyFrom
41 -> m (Event t TickInfo)
41 -> m (Event t TickInfo)
42tickLossyFrom dt t0 e = performEventAsync $ fmap callAtNextInterval e
42tickLossyFrom dt t0 e = performEventAsync $ fmap callAtNextInterval e
43 where callAtNextInterval _ cb = void $ liftIO $ forkIO $ forever $ do
43 where callAtNextInterval _ cb = void $ liftIO $ forkIO $ forever $ do
44+ tick <- getCurrentTick dt t0
45+ threadDelay $ ceiling $ (dt - _tickInfo_alreadyElapsed tick) * 1000000
46+ cb tick
47+
48+clockLossy :: MonadWidget t m => NominalDiffTime -> UTCTime -> m (Dynamic t TickInfo)
49+clockLossy dt t0 = do
50+ initial <- liftIO $ getCurrentTick dt t0
51+ e <- tickLossy dt t0
52+ holdDyn initial e
53+
54+getCurrentTick :: NominalDiffTime -> UTCTime -> IO TickInfo
55+getCurrentTick dt t0 = do
44− t <- getCurrentTime
56+ t <- getCurrentTime
45− let offset = t `diffUTCTime` t0
57+ let offset = t `diffUTCTime` t0
46− (n, alreadyElapsed) = offset `divMod'` dt
58+ (n, alreadyElapsed) = offset `divMod'` dt
47− threadDelay $ ceiling $ (dt - alreadyElapsed) * 1000000
48− cb $ TickInfo t n alreadyElapsed
59+ return $ TickInfo t n alreadyElapsed
49
60
50-- | Delay an Event's occurrences by a given amount in seconds.
61-- | Delay an Event's occurrences by a given amount in seconds.
51delay :: MonadWidget t m => NominalDiffTime -> Event t a -> m (Event t a)
62delay :: MonadWidget t m => NominalDiffTime -> Event t a -> m (Event t a)
src/Reflex/Dom/WebSocket.hsnew file+63
@@ -0,0 +1,63 @@
1+{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI, CPP, TemplateHaskell, NoMonomorphismRestriction, EmptyDataDecls, RankNTypes, GADTs, RecursiveDo, ScopedTypeVariables, FlexibleInstances, MultiParamTypeClasses, TypeFamilies, FlexibleContexts, DeriveDataTypeable, GeneralizedNewtypeDeriving, StandaloneDeriving, ConstraintKinds, UndecidableInstances, PolyKinds, AllowAmbiguousTypes #-}
2+
3+module Reflex.Dom.WebSocket where
4+
5+import Prelude hiding (div, span, mapM, mapM_, concat, concatMap, all, sequence)
6+
7+import Reflex
8+import Reflex.Host.Class
9+import Reflex.Dom.Class
10+import Reflex.Dom.WebSocket.Foreign
11+
12+import Control.Concurrent
13+import Control.Lens
14+import Control.Monad hiding (forM, forM_, mapM, mapM_, sequence)
15+import Control.Monad.IO.Class
16+import Control.Monad.Ref
17+import Control.Monad.State
18+import Data.ByteString (ByteString)
19+import Data.Default
20+import Data.Dependent.Map (DSum (..))
21+import Data.IORef
22+
23+data WebSocketConfig t
24+ = WebSocketConfig { _webSocketConfig_send :: Event t [ByteString]
25+ }
26+
27+instance Reflex t => Default (WebSocketConfig t) where
28+ def = WebSocketConfig never
29+
30+data WebSocket t
31+ = WebSocket { _webSocket_recv :: Event t ByteString
32+ }
33+
34+webSocket :: forall t m. (HasWebView m, MonadWidget t m) => String -> WebSocketConfig t -> m (WebSocket t)
35+webSocket url config = do
36+ wv <- fmap unWebViewSingleton askWebView
37+ postGui <- askPostGui
38+ runWithActions <- askRunWithActions
39+ (eRecv, eRecvTriggerRef) <- newEventWithTriggerRef
40+ currentSocketRef <- liftIO $ newIORef Nothing
41+ --TODO: Disconnect if value no longer needed
42+ let onMessage :: ByteString -> IO ()
43+ onMessage m = postGui $ do
44+ mt <- readRef eRecvTriggerRef
45+ forM_ mt $ \t -> runWithActions [t :=> m]
46+ start = do
47+ ws <- liftIO $ newWebSocket wv url onMessage $ do
48+ void $ forkIO $ do --TODO: Is the fork necessary, or do event handlers run in their own threads automatically?
49+ liftIO $ writeIORef currentSocketRef Nothing
50+ liftIO $ threadDelay 1000000
51+ start
52+ liftIO $ writeIORef currentSocketRef $ Just ws
53+ return ()
54+ schedulePostBuild $ liftIO start
55+ performEvent_ $ ffor (_webSocketConfig_send config) $ \payloads -> forM_ payloads $ \payload -> do
56+ mws <- liftIO $ readIORef currentSocketRef
57+ case mws of
58+ 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?
59+ Just ws -> do
60+ liftIO $ webSocketSend ws payload
61+ return $ WebSocket eRecv
62+
63+makeLensesWith (lensRules & simpleLenses .~ True) ''WebSocketConfig
src/Reflex/Dom/Widget.hs+2
@@ -1,8 +1,10 @@
1module Reflex.Dom.Widget ( module Reflex.Dom.Widget.Basic
1module Reflex.Dom.Widget ( module Reflex.Dom.Widget.Basic
2 , module Reflex.Dom.Widget.Input
2 , module Reflex.Dom.Widget.Input
3 , module Reflex.Dom.Widget.Lazy
3 , module Reflex.Dom.Widget.Lazy
4+ , module Reflex.Dom.Widget.Resize
4 ) where
5 ) where
5
6
6import Reflex.Dom.Widget.Basic
7import Reflex.Dom.Widget.Basic
7import Reflex.Dom.Widget.Input
8import Reflex.Dom.Widget.Input
8import Reflex.Dom.Widget.Lazy
9import Reflex.Dom.Widget.Lazy
10+import Reflex.Dom.Widget.Resize
src/Reflex/Dom/Widget/Basic.hs+11−4
@@ -277,19 +277,26 @@ listViewWithKey' :: (Ord k, MonadWidget t m) => Dynamic t (Map k v) -> (k -> Dyn
277listViewWithKey' vals mkChild = liftM current $ listWithKey vals mkChild
277listViewWithKey' vals mkChild = liftM current $ listWithKey vals mkChild
278
278
279-- | Create a dynamically-changing set of widgets, one of which is selected at any time.
279-- | Create a dynamically-changing set of widgets, one of which is selected at any time.
280−selectViewListWithKey_ :: forall t m k v a. (MonadWidget t m, Ord k)
280+selectViewListWithKey :: forall t m k v a. (MonadWidget t m, Ord k)
281 => Dynamic t k -- ^ Current selection key
281 => Dynamic t k -- ^ Current selection key
282 -> Dynamic t (Map k v) -- ^ Dynamic key/value map
282 -> Dynamic t (Map k v) -- ^ Dynamic key/value map
283 -> (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
283 -> (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
284− -> m (Event t k) -- ^ Event that fires when any child's return Event fires. Contains key of an arbitrary firing widget.
284+ -> m (Event t (k, a)) -- ^ Event that fires when any child's return Event fires. Contains key of an arbitrary firing widget.
285−selectViewListWithKey_ selection vals mkChild = do
285+selectViewListWithKey selection vals mkChild = do
286 let selectionDemux = demux selection -- For good performance, this value must be shared across all children
286 let selectionDemux = demux selection -- For good performance, this value must be shared across all children
287 selectChild <- listWithKey vals $ \k v -> do
287 selectChild <- listWithKey vals $ \k v -> do
288 selected <- getDemuxed selectionDemux k
288 selected <- getDemuxed selectionDemux k
289 selectSelf <- mkChild k v selected
289 selectSelf <- mkChild k v selected
290− return $ fmap (const k) selectSelf
290+ return $ fmap ((,) k) selectSelf
291 liftM switchPromptlyDyn $ mapDyn (leftmost . Map.elems) selectChild
291 liftM switchPromptlyDyn $ mapDyn (leftmost . Map.elems) selectChild
292
292
293+selectViewListWithKey_ :: forall t m k v a. (MonadWidget t m, Ord k)
294+ => Dynamic t k -- ^ Current selection key
295+ -> Dynamic t (Map k v) -- ^ Dynamic key/value map
296+ -> (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
297+ -> m (Event t k) -- ^ Event that fires when any child's return Event fires. Contains key of an arbitrary firing widget.
298+selectViewListWithKey_ selection vals mkChild = liftM (fmap fst) $ selectViewListWithKey selection vals mkChild
299+
293--------------------------------------------------------------------------------
300--------------------------------------------------------------------------------
294-- Basic DOM manipulation helpers
301-- Basic DOM manipulation helpers
295--------------------------------------------------------------------------------
302--------------------------------------------------------------------------------
src/Reflex/Dom/Widget/Input.hs+1
@@ -49,6 +49,7 @@ instance Reflex t => Default (TextInputConfig t) where
49 , _textInputConfig_attributes = constDyn mempty
49 , _textInputConfig_attributes = constDyn mempty
50 }
50 }
51
51
52+-- | 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.
52textInput :: MonadWidget t m => TextInputConfig t -> m (TextInput t)
53textInput :: MonadWidget t m => TextInputConfig t -> m (TextInput t)
53textInput (TextInputConfig inputType initial eSetValue dAttrs) = do
54textInput (TextInputConfig inputType initial eSetValue dAttrs) = do
54 e <- liftM castToHTMLInputElement $ buildEmptyElement "input" =<< mapDyn (Map.insert "type" inputType) dAttrs
55 e <- liftM castToHTMLInputElement $ buildEmptyElement "input" =<< mapDyn (Map.insert "type" inputType) dAttrs
src/Reflex/Dom/Widget/Lazy.hs+69
@@ -6,12 +6,15 @@ import Reflex
6import Reflex.Dom.Class
6import Reflex.Dom.Class
7import Reflex.Dom.Widget.Basic
7import Reflex.Dom.Widget.Basic
8
8
9+import Control.Monad
9import Control.Monad.IO.Class
10import Control.Monad.IO.Class
10import Data.Fixed
11import Data.Fixed
11import Data.Monoid
12import Data.Monoid
12import qualified Data.Map as Map
13import qualified Data.Map as Map
13import Data.Map (Map)
14import Data.Map (Map)
14import GHCJS.DOM.Element
15import GHCJS.DOM.Element
16+import Data.Maybe
17+import Data.Int
15
18
16-- |A list view for long lists. Creates a scrollable element and only renders child row elements near the current scroll position.
19-- |A list view for long lists. Creates a scrollable element and only renders child row elements near the current scroll position.
17virtualListWithSelection :: forall t m k v. (MonadWidget t m, Ord k)
20virtualListWithSelection :: forall t m k v. (MonadWidget t m, Ord k)
@@ -67,4 +70,70 @@ virtualListWithSelection heightPx rowPx maxIndex i0 setI listTag listAttrs rowTa
67 preItems = min startingIndex numItems
70 preItems = min startingIndex numItems
68 in (topPx - preItems * sizeIncrement, (startingIndex - preItems, preItems + numItems * 2))
71 in (topPx - preItems * sizeIncrement, (startingIndex - preItems, preItems + numItems * 2))
69
72
73+virtualList :: forall t m k v a. (MonadWidget t m, Ord k)
74+ => Dynamic t Int -- ^ A 'Dynamic' of the visible region's height in pixels
75+ -> Int -- ^ The fixed height of each row in pixels
76+ -> Dynamic t Int -- ^ A 'Dynamic' of the total number of items
77+ -> Int -- ^ The index of the row to scroll to on initialization
78+ -> Event t Int -- ^ An 'Event' containing a row index. Used to scroll to the given index.
79+ -> (k -> Int) -- ^ Key to Index function, used to position items.
80+ -> Map k v -- ^ The initial 'Map' of items
81+ -> Event t (Map k (Maybe v)) -- ^ The update 'Event'. Nothing values are removed from the list and Just values are added or updated.
82+ -> (k -> v -> Event t v -> m a) -- ^ The row child element builder.
83+ -> 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
84+virtualList heightPx rowPx maxIndex i0 setI keyToIndex items0 itemsUpdate itemBuilder = do
85+ virtualH <- mapDyn (mkVirtualHeight . (*) rowPx) maxIndex
86+ containerStyle <- mapDyn mkContainer heightPx
87+ viewportStyle <- mapDyn mkViewport heightPx
88+ pb <- getPostBuild
89+ rec (viewport, result) <- elDynAttr "div" containerStyle $ elDynAttr' "div" viewportStyle $ elDynAttr "div" virtualH $
90+ listWithKeyShallowDiff items0 itemsUpdate $ \k v e -> elAttr "div" (mkRow k) $ itemBuilder k v e
91+ scrollPosition <- holdDyn 0 $ leftmost [ domEvent Scroll viewport
92+ , fmap (const (i0 * rowPx)) pb
93+ ]
94+ window <- combineDyn (\h -> findWindow h rowPx) heightPx scrollPosition
95+ performEvent_ $ fmap (\i -> liftIO $ elementSetScrollTop (_el_element viewport) (i * rowPx)) $ leftmost [setI, fmap (const i0) pb]
96+ return (nubDyn window, result)
97+ where
98+ toStyleAttr m = "style" =: (Map.foldWithKey (\k v s -> k <> ":" <> v <> ";" <> s) "" m)
99+ mkViewport h = toStyleAttr $ "overflow" =: "auto" <> "position" =: "absolute" <>
100+ "left" =: "0" <> "right" =: "0" <> "height" =: (show h <> "px")
101+ mkContainer h = toStyleAttr $ "position" =: "relative" <> "height" =: (show h <> "px")
102+ mkVirtualHeight h = let h' = h * rowPx
103+ in toStyleAttr $ "height" =: (show h <> "px") <>
104+ "overflow" =: "hidden" <>
105+ "position" =: "relative"
106+ mkRow k = toStyleAttr $ "height" =: (show rowPx <> "px") <>
107+ "top" =: ((<>"px") $ show $ keyToIndex k * rowPx) <>
108+ "position" =: "absolute" <>
109+ "width" =: "100%"
110+ findWindow windowSize sizeIncrement startingPosition =
111+ let (startingIndex, topOffsetPx) = startingPosition `divMod'` sizeIncrement
112+ numItems = (windowSize + sizeIncrement - 1) `div` sizeIncrement
113+ in (startingIndex, numItems)
70
114
115+virtualListBuffered
116+ :: (Ord k, MonadWidget t m)
117+ => Int
118+ -> Dynamic t Int
119+ -> Int
120+ -> Dynamic t Int
121+ -> Int
122+ -> Event t Int
123+ -> (k -> Int)
124+ -> Map k v
125+ -> Event t (Map k (Maybe v))
126+ -> (k -> v -> Event t v -> m a)
127+ -> m (Event t (Int, Int), Dynamic t (Map k a))
128+virtualListBuffered buffer heightPx rowPx maxIndex i0 setI keyToIndex items0 itemsUpdate itemBuilder = do
129+ (win, m) <- virtualList heightPx rowPx maxIndex i0 setI keyToIndex items0 itemsUpdate itemBuilder
130+ pb <- getPostBuild
131+ let extendWin o l = (max 0 (o - l * (buffer-1) `div` 2), l * buffer)
132+ rec let winHitEdge = fmapMaybe id $ attachWith (\(oldOffset, oldLimit) (winOffset, winLimit) ->
133+ if winOffset > oldOffset && winOffset + winLimit < oldOffset + oldLimit
134+ then Nothing
135+ else Just (extendWin winOffset winLimit)) (current winBuffered) (updated win)
136+ winBuffered <- holdDyn (0, 0) $ leftmost [ winHitEdge
137+ , fmap (uncurry extendWin) $ tagDyn win pb
138+ ]
139+ return (updated winBuffered, m)
src/Reflex/Dom/Widget/Resize.hsnew file+62
@@ -0,0 +1,62 @@
1+{-# LANGUAGE RecursiveDo #-}
2+module Reflex.Dom.Widget.Resize where
3+
4+import Reflex
5+import Reflex.Dom.Class
6+import Reflex.Dom.Widget.Basic
7+
8+import Control.Monad
9+import Control.Monad.IO.Class
10+import Data.Monoid
11+import GHCJS.DOM.Element
12+
13+-- | A widget that wraps the given widget in a div and fires an event when resized.
14+-- Adapted from github.com/marcj/css-element-queries
15+resizeDetector :: MonadWidget t m => m a -> m (Event t (), a)
16+resizeDetector = resizeDetectorWithStyle ""
17+
18+resizeDetectorWithStyle :: MonadWidget t m
19+ => String -- ^ A css style string. Warning: It should not contain the "position" style attribute.
20+ -> m a -- ^ The embedded widget
21+ -> m (Event t (), a) -- ^ An 'Event' that fires on resize, and the result of the embedded widget
22+resizeDetectorWithStyle styleString w = do
23+ let childStyle = "position: absolute; left: 0; top: 0;"
24+ containerAttrs = "style" =: "position: absolute; left: 0; top: 0; right: 0; bottom: 0; overflow: scroll; z-index: -1; visibility: hidden;"
25+ (parent, (expand, expandChild, shrink, w')) <- elAttr' "div" ("style" =: ("position: relative;" <> styleString)) $ do
26+ w' <- w
27+ elAttr "div" containerAttrs $ do
28+ (expand, (expandChild, _)) <- elAttr' "div" containerAttrs $ elAttr' "div" ("style" =: childStyle) $ return ()
29+ (shrink, _) <- elAttr' "div" containerAttrs $ elAttr "div" ("style" =: (childStyle <> "width: 200%; height: 200%;")) $ return ()
30+ return (expand, expandChild, shrink, w')
31+ let reset = do
32+ let e = _el_element expand
33+ s = _el_element shrink
34+ eow <- elementGetOffsetWidth e
35+ eoh <- elementGetOffsetHeight e
36+ let ecw = eow + 10
37+ ech = eoh + 10
38+ elementSetAttribute (_el_element expandChild) "style" (childStyle <> "width: " <> show ecw <> "px;" <> "height: " <> show ech <> "px;")
39+ esw <- elementGetScrollWidth e
40+ elementSetScrollLeft e esw
41+ esh <- elementGetScrollHeight e
42+ elementSetScrollTop e esh
43+ ssw <- elementGetScrollWidth s
44+ elementSetScrollLeft s ssw
45+ ssh <- elementGetScrollHeight s
46+ elementSetScrollTop s ssh
47+ lastWidth <- elementGetOffsetWidth (_el_element parent)
48+ lastHeight <- elementGetOffsetHeight (_el_element parent)
49+ return (Just lastWidth, Just lastHeight)
50+ resetIfChanged ds = do
51+ pow <- elementGetOffsetWidth (_el_element parent)
52+ poh <- elementGetOffsetHeight (_el_element parent)
53+ if ds == (Just pow, Just poh)
54+ then return Nothing
55+ else liftM Just reset
56+ pb <- getPostBuild
57+ expandScroll <- wrapDomEvent (_el_element expand) elementOnscroll $ return ()
58+ shrinkScroll <- wrapDomEvent (_el_element shrink) elementOnscroll $ return ()
59+ size0 <- performEvent $ fmap (const $ liftIO reset) pb
60+ rec resize <- performEventAsync $ fmap (\d cb -> liftIO $ cb =<< resetIfChanged d) $ tag (current dimensions) $ leftmost [expandScroll, shrinkScroll]
61+ dimensions <- holdDyn (Nothing, Nothing) $ leftmost [ size0, fmapMaybe id resize ]
62+ return (fmap (const ()) $ fmapMaybe id resize, w')
src/Reflex/Dom/Xhr.hs+17−1
@@ -21,6 +21,9 @@ import Control.Lens
21import Control.Monad hiding (forM)
21import Control.Monad hiding (forM)
22import Control.Monad.IO.Class
22import Control.Monad.IO.Class
23import Data.Aeson
23import Data.Aeson
24+import Data.Aeson.Encode
25+import qualified Data.Text.Lazy as LT
26+import qualified Data.Text.Lazy.Builder as B
24import qualified Data.ByteString.Lazy as BL
27import qualified Data.ByteString.Lazy as BL
25import Data.Default
28import Data.Default
26import Data.Map (Map)
29import Data.Map (Map)
@@ -52,6 +55,8 @@ data XhrRequestConfig a
52
55
53data XhrResponse
56data XhrResponse
54 = XhrResponse { _xhrResponse_body :: Maybe Text
57 = XhrResponse { _xhrResponse_body :: Maybe Text
58+ , _xhrResponse_status :: Word
59+ , _xhrResponse_statusText :: Text
55 }
60 }
56 deriving (Show, Read, Eq, Ord, Typeable)
61 deriving (Show, Read, Eq, Ord, Typeable)
57
62
@@ -85,10 +90,12 @@ newXMLHttpRequest req cb = do
85 maybe (return ()) (xmlHttpRequestSetResponseType xhr . toResponseType) (_xhrRequestConfig_responseType c)
90 maybe (return ()) (xmlHttpRequestSetResponseType xhr . toResponseType) (_xhrRequestConfig_responseType c)
86 _ <- xmlHttpRequestOnreadystatechange xhr $ do
91 _ <- xmlHttpRequestOnreadystatechange xhr $ do
87 readyState <- liftIO $ xmlHttpRequestGetReadyState xhr
92 readyState <- liftIO $ xmlHttpRequestGetReadyState xhr
93+ status <- liftIO $ xmlHttpRequestGetStatus xhr
94+ statusText <- liftIO $ xmlHttpRequestGetStatusText xhr
88 if readyState == 4
95 if readyState == 4
89 then do
96 then do
90 r <- liftIO $ xmlHttpRequestGetResponseText xhr
97 r <- liftIO $ xmlHttpRequestGetResponseText xhr
91− _ <- liftIO $ postGui $ cb $ XhrResponse $ responseTextToText r
98+ _ <- liftIO $ postGui $ cb $ XhrResponse (responseTextToText r) status (statusTextToText statusText)
92 return ()
99 return ()
93 else return ()
100 else return ()
94 _ <- xmlHttpRequestSend xhr (_xhrRequestConfig_sendData c)
101 _ <- xmlHttpRequestSend xhr (_xhrRequestConfig_sendData c)
@@ -116,6 +123,15 @@ getAndDecode url = do
116 r <- performRequestAsync $ fmap (\x -> XhrRequest "GET" x def) url
123 r <- performRequestAsync $ fmap (\x -> XhrRequest "GET" x def) url
117 return $ fmap decodeXhrResponse r
124 return $ fmap decodeXhrResponse r
118
125
126+-- | Create a "POST" request from an URL and thing with a JSON representation
127+postJson :: (ToJSON a) => String -> a -> XhrRequest String
128+postJson url a =
129+ XhrRequest "POST" url $ def { _xhrRequestConfig_headers = headerUrlEnc
130+ , _xhrRequestConfig_sendData = body
131+ }
132+ where headerUrlEnc = "Content-type" =: "application/json"
133+ body = LT.unpack $ B.toLazyText $ encodeToTextBuilder $ toJSON a
134+
119getMay :: MonadWidget t m => (Event t a -> m (Event t b)) -> Event t (Maybe a) -> m (Event t (Maybe b))
135getMay :: MonadWidget t m => (Event t a -> m (Event t b)) -> Event t (Maybe a) -> m (Event t (Maybe b))
120getMay f e = do
136getMay f e = do
121 e' <- f (fmapMaybe id e)
137 e' <- f (fmapMaybe id e)