git.iko.soy/reflex-dom
on develop help sign in
Merge branch 'develop' of github.com:reflex-frp/reflex-dom into xhrheaders
commitde78254442d051c2eec955386c73d71ee24dee6e authorGreg Hale <imalsogreg@gmail.com> dateSat 27 Aug 2016, 21:01 (10 years ago) parent0b1c02277e0c27
27 files changed+643−812
compare with develop
unifiedsplit
Quickref.md+19−22 reflex-dom.cabal+1−5 src-ghc/Reflex/Dom/WebSocket/Foreign.hs+29−15 src-ghc/Reflex/Dom/Xhr/Foreign.hs+3 src-ghcjs/Reflex/Dom/WebSocket/Foreign.hs+18−8 src-ghcjs/Reflex/Dom/Xhr/Foreign.hs+3 src/Foreign/JavaScript/TH.hs+88−12 src/Reflex/Dom.hs+1−3 src/Reflex/Dom/Builder/Class.hs+215−27 src/Reflex/Dom/Builder/Immediate.hs+57−11 src/Reflex/Dom/Builder/InputDisabled.hs+90 src/Reflex/Dom/Builder/Static.hs+29−5 src/Reflex/Dom/Class.hs+2−2 src/Reflex/Dom/Deletable/Class.hs−17 src/Reflex/Dom/DynamicWriter.hs−241 src/Reflex/Dom/Internal.hs+10−2 src/Reflex/Dom/Old.hs+5−5 src/Reflex/Dom/PerformEvent/Base.hs−177 src/Reflex/Dom/PerformEvent/Class.hs−46 src/Reflex/Dom/PostBuild/Class.hs−128 src/Reflex/Dom/Time.hs+4−3 src/Reflex/Dom/WebSocket.hs+13−7 src/Reflex/Dom/Widget/Basic.hs+5−30 src/Reflex/Dom/Widget/Input.hs+42−38 src/Reflex/Dom/Widget/Lazy.hs+4−3 src/Reflex/Dom/Widget/Resize.hs+3−3 src/Reflex/Dom/Xhr.hs+2−2
Quickref.md+19−22
@@ -23,41 +23,38 @@ Widgets may return any type (this is 'a' in many of the functions below). Often
2323```haskell
2424-- Simplest form. Create a widget of given type containing the given child.
2525-- Return whatever the child returns.
26−[W] el :: String -> m a -> m a
26+[W] el :: Text -> m a -> m a
2727
2828-- This version returns the 'El' as well.
29−[W] el' :: String -> m a -> m (El, a)
29+[W] el' :: Text -> m a -> m (El, a)
3030
3131-- These two additionally apply attributes to the element, such as ("class" =: "blah")
32−[W] elAttr :: String -> Map String String -> m a -> m a
33−[W] elAttr' :: String -> Map String String -> m a -> m (El, a)
32+[W] elAttr :: Text -> Map Text Text -> m a -> m a
33+[W] elAttr' :: Text -> Map Text Text -> m a -> m (El, a)
3434
3535-- As above, but now the attribute map is Dynamic
36−[W] elDynAttr :: String -> Dynamic (Map String String) -> m a -> m a
37−[W] elDynAttr' :: String -> Dynamic (Map String String) -> m a -> m (El, a)
36+[W] elDynAttr :: Text -> Dynamic (Map Text Text) -> m a -> m a
37+[W] elDynAttr' :: Text -> Dynamic (Map Text Text) -> m a -> m (El, a)
3838
3939-- Shortcut for elAttr when you only want to set the "class" attribute.
40−[W] elClass :: String -> String -> m a -> m a
40+[W] elClass :: Text -> Text -> m a -> m a
4141
4242-- Even shorter-cut for above when element type is "div". Create a div of given class.
43−[W] divClass :: String -> m a -> m a
43+[W] divClass :: Text -> m a -> m a
4444
4545-- Create a widget of given type with arbitrary, Dymamic HTML inside.
46−[W] elDynHtml' :: String -> Dynamic String -> m El
47−[W] elDynHtmlAttr' :: String -> Map String String -> Dynamic String -> m El
48−
49−-- Shortcut for elDynHtml' where the type is "div" and you don't need the 'El'.
50−[W] dynHtml :: Dynamic String -> m ()
46+[W] elDynHtml' :: Text -> Dynamic Text -> m El
47+[W] elDynHtmlAttr' :: Text -> Map Text Text -> Dynamic Text -> m El
5148
5249-- Create a static text element
53−[W] text :: String -> m ()
50+[W] text :: Text -> m ()
5451
5552-- Create a dynamic text element
56−[W] dynText :: Dynamic String -> m ()
53+[W] dynText :: Dynamic Text -> m ()
5754[W] display :: Show a => Dynamic a -> m ()
5855
5956-- Create a "button" element with given label, return onClick Event
60−[W] button :: String -> m (Event ())
57+[W] button :: Text -> m (Event ())
6158
6259-- Empty widget
6360[W] blank :: m ()
@@ -121,13 +118,13 @@ Some of these widget builders take a configuration record and return a record co
121118
122119-- Dropdown with Dynamic options. First argument is initial state.
123120[W] dropdown :: (Ord k, Show k, Read k) =>
124− k -> Dynamic (Map k String) -> DropdownConfig k -> m (Dropdown k)
121+ k -> Dynamic (Map k Text) -> DropdownConfig k -> m (Dropdown k)
125122
126123-- Table with static columns and dynamic rows.
127124[W] tableDynAttr :: ... -- See Reflex.Dom.Widget.Basic
128125
129126-- Tabbed view that shows only one of its child widgets at a time.
130−[W] tabDisplay :: (Show k, Ord k) => String -> String -> Map k (String, m ()) -> m ()
127+[W] tabDisplay :: (Show k, Ord k) => Text -> Text -> Map k (Text, m ()) -> m ()
131128
132129-- Widget to efficiently display long scrolling lists.
133130[W] virtualListWithSelection :: ... -- See Reflex.Dom.Widget.Lazy
@@ -163,19 +160,19 @@ Convenience functions for XMLHttpRequest. see Reflex.Dom.Xhr
163160
164161```haskell
165162-- Given method, URL, and config record (with default instance), construct a request.
166−[ ] xhrRequest :: String -> String -> XhrRequestConfig -> XhrRequest
163+[ ] xhrRequest :: Text -> Text -> XhrRequestConfig a -> XhrRequest a
167164
168165-- Given Event of requests, issue them and produce Event of responses.
169−[W] performRequestAsync :: Event XhrRequest -> m (Event XhrResponse)
166+[W] performRequestAsync :: Event (XhrRequest a) -> m (Event XhrResponse)
170167
171168-- Issue a collection of requests, wait for them ALL to complete, return collected results.
172−[W] performRequestsAsync :: Traversable f => Event (f XhrRequest) -> m (Event (f XhrResponse))
169+[W] performRequestsAsync :: Traversable f => Event (f (XhrRequest a)) -> m (Event (f XhrResponse))
173170
174171-- Convenience function to decode JSON-encoded responses.
175172[ ] decodeXhrResponse :: FromJSON a => XhrResponse -> Maybe a
176173
177174-- Simplified interface to "GET" URLs and return decoded results.
178−[W] getAndDecode :: FromJSON a => Event String -> m (Event (Maybe a))
175+[W] getAndDecode :: FromJSON a => Event Text -> m (Event (Maybe a))
179176```
180177
181178### Time
reflex-dom.cabal+1−5
@@ -78,16 +78,12 @@ library
7878 Reflex.Dom.Builder.Class
7979 Reflex.Dom.Builder.Class.Events
8080 Reflex.Dom.Builder.Immediate
81+ Reflex.Dom.Builder.InputDisabled
8182 Reflex.Dom.Builder.Static
8283 Reflex.Dom.Class
83− Reflex.Dom.Deletable.Class
84− Reflex.Dom.DynamicWriter
8584 Reflex.Dom.Internal
8685 Reflex.Dom.Internal.Foreign
8786 Reflex.Dom.Location
88− Reflex.Dom.PerformEvent.Base
89− Reflex.Dom.PerformEvent.Class
90− Reflex.Dom.PostBuild.Class
9187 Reflex.Dom.Old
9288 Reflex.Dom.Time
9389 Reflex.Dom.WebSocket
src-ghc/Reflex/Dom/WebSocket/Foreign.hs+29−15
@@ -1,3 +1,4 @@
1+{-# LANGUAGE TemplateHaskell #-}
12{-# LANGUAGE AllowAmbiguousTypes #-}
23{-# LANGUAGE ConstraintKinds #-}
34{-# LANGUAGE FlexibleContexts #-}
@@ -32,12 +33,40 @@ import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSStringRef
3233import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSValueRef
3334import Graphics.UI.Gtk.WebKit.WebView
3435
36+import Foreign.JavaScript.TH
3537import Reflex.Dom.Internal.Foreign
3638
3739data JSWebSocket = JSWebSocket { wsValue :: JSValueRef
3840 , wsContext :: JSContextRef
3941 }
4042
43+importJS Unsafe "this[0]['send'](this[1])" "_sendWSTextData" [t| forall x m. MonadJS x m => JSRef x -> String -> m () |]
44+
45+sendWSTextData :: JSWebSocket -> String -> IO ()
46+sendWSTextData (JSWebSocket ws c) str = runWithJSContext (_sendWSTextData (JSRef_JavaScriptCore ws) str) c
47+
48+class IsWebSocketMessage a where
49+ webSocketSend :: JSWebSocket -> a -> IO ()
50+
51+-- Use binary websocket communication for ByteString
52+instance IsWebSocketMessage ByteString where
53+ webSocketSend (JSWebSocket ws c) bs = do
54+ elems <- forM (BS.unpack bs) $ \x -> jsvaluemakenumber c $ fromIntegral x
55+ let numElems = length elems
56+ bs' <- bracket (mallocArray numElems) free $ \elemsArr -> do
57+ pokeArray elemsArr elems
58+ a <- jsobjectmakearray c (fromIntegral numElems) elemsArr nullPtr
59+ newUint8Array <- jsstringcreatewithutf8cstring "new Uint8Array(this)"
60+ jsevaluatescript c newUint8Array a nullPtr 1 nullPtr
61+ send <- jsstringcreatewithutf8cstring ""
62+ sendArgs <- toJSObject c [ws, bs']
63+ _ <- jsevaluatescript c send sendArgs nullPtr 1 nullPtr
64+ return ()
65+
66+-- Use plaintext websocket communication for Text
67+instance IsWebSocketMessage Text where
68+ webSocketSend jws t = sendWSTextData jws (T.unpack t)
69+
4170newWebSocket :: WebView -> Text -> (ByteString -> IO ()) -> IO () -> IO () -> IO JSWebSocket
4271newWebSocket wv url onMessage onOpen onClose = withWebViewContext wv $ \c -> do
4372 url' <- jsvaluemakestring c =<< jsstringcreatewithutf8cstring (T.unpack url)
@@ -66,18 +95,3 @@ newWebSocket wv url onMessage onOpen onClose = withWebViewContext wv $ \c -> do
6695 addCbs <- jsstringcreatewithutf8cstring "this[0]['onmessage'] = this[1]; this[0]['onopen'] = this[2]; this[0]['onclose'] = this[3];"
6796 _ <- jsevaluatescript c addCbs o nullPtr 1 nullPtr
6897 return $ JSWebSocket ws c
69−
70−webSocketSend :: JSWebSocket -> ByteString -> IO ()
71−webSocketSend (JSWebSocket ws c) bs = do
72− elems <- forM (BS.unpack bs) $ \x -> jsvaluemakenumber c $ fromIntegral x
73− let numElems = length elems
74− bs' <- bracket (mallocArray numElems) free $ \elemsArr -> do
75− pokeArray elemsArr elems
76− a <- jsobjectmakearray c (fromIntegral numElems) elemsArr nullPtr
77− newUint8Array <- jsstringcreatewithutf8cstring "new Uint8Array(this)"
78− jsevaluatescript c newUint8Array a nullPtr 1 nullPtr
79− send <- jsstringcreatewithutf8cstring "this[0]['send'](String['fromCharCode']['apply'](null, this[1]))"
80− sendArgs <- toJSObject c [ws, bs']
81− _ <- jsevaluatescript c send sendArgs nullPtr 1 nullPtr
82− return ()
83−
src-ghc/Reflex/Dom/Xhr/Foreign.hs+3
@@ -40,6 +40,9 @@ instance IsXhrPayload () where
4040instance IsXhrPayload Text where
4141 xmlHttpRequestSend xhr = xmlHttpRequestSendPayload xhr . Just
4242
43+instance IsXhrPayload String where
44+ xmlHttpRequestSend xhr = xmlHttpRequestSendPayload xhr . Just . T.pack
45+
4346instance IsXhrPayload File where
4447 xmlHttpRequestSend = error "xmlHttpRequestSend{File}: not implemented"
4548
src-ghcjs/Reflex/Dom/WebSocket/Foreign.hs+18−8
@@ -10,6 +10,7 @@ import Control.Monad.Reader
1010import Data.ByteString (ByteString)
1111import qualified Data.ByteString as BS
1212import Data.Text (Text)
13+import qualified Data.Text as T (unpack)
1314import Data.Text.Encoding
1415import GHCJS.Buffer
1516import GHCJS.DOM.EventM (on)
@@ -24,6 +25,23 @@ import JavaScript.TypedArray.ArrayBuffer as JS
2425
2526data JSWebSocket = JSWebSocket { unWebSocket :: WebSocket }
2627
28+class IsWebSocketMessage a where
29+ webSocketSend :: JSWebSocket -> a -> IO ()
30+
31+-- Use binary websocket communication for ByteString
32+-- Note: Binary websockets may not work correctly in IE 11 and below
33+instance IsWebSocketMessage ByteString where
34+ webSocketSend (JSWebSocket ws) bs = do
35+ let (b, off, len) = fromByteString bs
36+ ab <- ArrayBuffer <$> if BS.length bs == 0 --TODO: remove this logic when https://github.com/ghcjs/ghcjs-base/issues/49 is fixed
37+ then jsval . getArrayBuffer <$> create 0
38+ else return $ js_dataView off len $ jsval $ getArrayBuffer b
39+ GD.send ws $ Just ab
40+
41+-- Use plaintext websocket communication for Text, and String
42+instance IsWebSocketMessage Text where
43+ webSocketSend (JSWebSocket ws) = GD.sendString ws . T.unpack
44+
2745newWebSocket :: a -> Text -> (ByteString -> IO ()) -> IO () -> IO () -> IO JSWebSocket
2846newWebSocket _ url onMessage onOpen onClose = do
2947 ws <- GD.newWebSocket url (Just [] :: Maybe [Text])
@@ -40,12 +58,4 @@ newWebSocket _ url onMessage onOpen onClose = do
4058 _ <- on ws closeEvent $ liftIO onClose
4159 return $ JSWebSocket ws
4260
43−webSocketSend :: JSWebSocket -> ByteString -> IO ()
44−webSocketSend (JSWebSocket ws) bs = do
45− let (b, off, len) = fromByteString bs
46− ab <- ArrayBuffer <$> if BS.length bs == 0 --TODO: remove this logic when https://github.com/ghcjs/ghcjs-base/issues/49 is fixed
47− then jsval . getArrayBuffer <$> create 0
48− else return $ js_dataView off len $ jsval $ getArrayBuffer b
49− GD.send ws $ Just ab
50−
5161foreign import javascript safe "new DataView($3,$1,$2)" js_dataView :: Int -> Int -> JSVal -> JSVal
src-ghcjs/Reflex/Dom/Xhr/Foreign.hs+3
@@ -49,6 +49,9 @@ instance IsXhrPayload () where
4949instance IsXhrPayload String where
5050 sendXhrPayload = sendString
5151
52+instance IsXhrPayload Text where
53+ sendXhrPayload = sendString
54+
5255instance IsXhrPayload FormData where
5356 sendXhrPayload = sendFormData
5457
src/Foreign/JavaScript/TH.hs+88−12
@@ -21,8 +21,11 @@ module Foreign.JavaScript.TH ( module Foreign.JavaScript.TH
2121 ) where
2222
2323import Reflex.Class
24−import Reflex.Dom.Deletable.Class
25−import Reflex.Dom.PerformEvent.Class
24+import Reflex.Deletable.Class
25+import Reflex.DynamicWriter
26+import Reflex.PerformEvent.Base
27+import Reflex.PerformEvent.Class
28+import Reflex.PostBuild.Class
2629import Reflex.Host.Class
2730
2831import Language.Haskell.TH
@@ -94,6 +97,18 @@ instance HasWebView m => HasWebView (Strict.StateT r m) where
9497 type WebViewPhantom (Strict.StateT r m) = WebViewPhantom m
9598 askWebView = lift askWebView
9699
100+instance HasWebView m => HasWebView (PostBuildT t m) where
101+ type WebViewPhantom (PostBuildT t m) = WebViewPhantom m
102+ askWebView = lift askWebView
103+
104+instance (ReflexHost t, HasWebView (HostFrame t)) => HasWebView (PerformEventT t m) where
105+ type WebViewPhantom (PerformEventT t m) = WebViewPhantom (HostFrame t)
106+ askWebView = PerformEventT $ lift askWebView
107+
108+instance HasWebView m => HasWebView (DynamicWriterT t w m) where
109+ type WebViewPhantom (DynamicWriterT t w m) = WebViewPhantom m
110+ askWebView = lift askWebView
111+
97112newtype WithWebView x m a = WithWebView { unWithWebView :: ReaderT (WebViewSingleton x) m a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadTrans, MonadException, MonadAsyncException)
98113
99114instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (WithWebView x m) where
@@ -191,6 +206,18 @@ instance HasJS x m => HasJS x (ReaderT r m) where
191206 type JSM (ReaderT r m) = JSM m
192207 liftJS = lift . liftJS
193208
209+instance (HasJS x m, ReflexHost t) => HasJS x (PostBuildT t m) where
210+ type JSM (PostBuildT t m) = JSM m
211+ liftJS = lift . liftJS
212+
213+instance (HasJS x (HostFrame t), ReflexHost t) => HasJS x (PerformEventT t m) where
214+ type JSM (PerformEventT t m) = JSM (HostFrame t)
215+ liftJS = PerformEventT . lift . liftJS
216+
217+instance HasJS x m => HasJS x (DynamicWriterT t w m) where
218+ type JSM (DynamicWriterT t w m) = JSM m
219+ liftJS = lift . liftJS
220+
194221-- | A Monad that is capable of executing JavaScript
195222class Monad m => MonadJS x m | m -> x where
196223 runJS :: JSFFI -> [JSRef x] -> m (JSRef x)
@@ -269,18 +296,13 @@ foreign import javascript unsafe "function(){ return $1(arguments); }" funWithAr
269296
270297#else
271298
272−askJSContext :: MonadIO m => WithWebView x m JSContextRef
273−askJSContext = do
274− wv <- askWebView
275− liftIO $ webFrameGetGlobalContext =<< webViewGetMainFrame (unWebViewSingleton wv)
276−
277299-- | Make a JS string available that is not wrapped up as a JSValueRef
278300withJSStringRaw :: MonadAsyncException m => String -> (JSStringRef -> m r) -> m r
279301withJSStringRaw str a = do
280302 bracket (liftIO $ jsstringcreatewithutf8cstring str) (liftIO . jsstringrelease) $ \strRef -> do
281303 a strRef
282304
283−fromJSNumberRaw :: MonadIO m => JSValueRef -> WithWebView x m Double
305+fromJSNumberRaw :: (MonadIO m, HasJSContext m) => JSValueRef -> m Double
284306fromJSNumberRaw val = do
285307 jsContext <- askJSContext
286308 liftIO $ jsvaluetonumber jsContext val nullPtr --TODO: Exceptions
@@ -297,15 +319,70 @@ instance MonadIO m => HasJS (JSCtx_JavaScriptCore x) (WithWebView x m) where
297319 wv <- askWebView
298320 liftIO $ runWithWebView a wv
299321
322+newtype WithJSContext x m a = WithJSContext { unWithJSContext :: ReaderT JSContextRef m a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadTrans, MonadException, MonadAsyncException)
323+
324+runWithJSContext :: WithJSContext x m a -> JSContextRef -> m a
325+runWithJSContext = runReaderT . unWithJSContext
326+
327+class Monad m => HasJSContext m where
328+ askJSContext :: m JSContextRef
329+
330+instance MonadIO m => HasJSContext (WithWebView x m) where
331+ askJSContext = do
332+ wv <- askWebView
333+ liftIO $ webFrameGetGlobalContext =<< webViewGetMainFrame (unWebViewSingleton wv)
334+
335+instance Monad m => HasJSContext (WithJSContext x m) where
336+ askJSContext = WithJSContext ask
337+
338+lowerWithJSContext :: (HasJSContext m, MonadIO m) => WithJSContext x IO a -> m a
339+lowerWithJSContext a = do
340+ c <- askJSContext
341+ liftIO $ runWithJSContext a c
342+
343+liftWithWebViewThroughWithJSContext :: (HasJSContext m, HasWebView m, MonadIO m, MonadTrans t, Monad m1)
344+ => ((t1 -> t m1 a) -> WithJSContext x IO b)
345+ -> (t1 -> WithWebView (WebViewPhantom m) m1 a)
346+ -> m b
347+liftWithWebViewThroughWithJSContext f a = do
348+ wv <- askWebView
349+ lowerWithJSContext $ f $ \b' -> lift $ runWithWebView (a b') wv
350+
300351instance MonadJS (JSCtx_JavaScriptCore x) (WithWebView x IO) where
352+ forkJS a = do
353+ wv <- askWebView
354+ liftIO $ forkIO $ runWithWebView a wv
355+ mkJSFun a = do
356+ wv <- askWebView
357+ lowerWithJSContext $ mkJSFun $ \args -> lift $ runWithWebView (a args) wv
358+ runJS expr args = lowerWithJSContext $ runJS expr args
359+ mkJSUndefined = lowerWithJSContext mkJSUndefined
360+ isJSNull = lowerWithJSContext . isJSNull
361+ isJSUndefined = lowerWithJSContext . isJSUndefined
362+ fromJSBool = lowerWithJSContext . fromJSBool
363+ fromJSString = lowerWithJSContext . fromJSString
364+ fromJSArray = lowerWithJSContext . fromJSArray
365+ fromJSUint8Array = lowerWithJSContext . fromJSUint8Array
366+ fromJSNumber = lowerWithJSContext . fromJSNumber
367+ freeJSFun = lowerWithJSContext . freeJSFun
368+ withJSBool = liftWithWebViewThroughWithJSContext . withJSBool
369+ withJSString = liftWithWebViewThroughWithJSContext . withJSString
370+ withJSNumber = liftWithWebViewThroughWithJSContext . withJSNumber
371+ withJSArray = liftWithWebViewThroughWithJSContext . withJSArray
372+ withJSUint8Array = liftWithWebViewThroughWithJSContext . withJSUint8Array
373+ withJSNode = liftWithWebViewThroughWithJSContext . withJSNode
374+ setJSProp propName valRef objRef = lowerWithJSContext $ setJSProp propName valRef objRef
375+ getJSProp propName objRef = lowerWithJSContext $ getJSProp propName objRef
376+
377+instance MonadJS (JSCtx_JavaScriptCore x) (WithJSContext x IO) where
301378 runJS (JSFFI body) args = do
302379 jsContext <- askJSContext
303380 withJSArray args $ \(JSRef_JavaScriptCore this) -> liftIO $ do
304381 result <- bracket (jsstringcreatewithutf8cstring body) jsstringrelease $ \script -> jsevaluatescript jsContext script this nullPtr 1 nullPtr
305382 return $ JSRef_JavaScriptCore result --TODO: Protect and unprotect result
306383 forkJS a = do
307− wv <- askWebView
308− liftIO $ forkIO $ runWithWebView a wv
384+ c <- askJSContext
385+ liftIO $ forkIO $ runWithJSContext a c
309386 mkJSUndefined = do
310387 jsContext <- askJSContext
311388 fmap JSRef_JavaScriptCore $ liftIO $ jsvaluemakeundefined jsContext
@@ -366,14 +443,13 @@ instance MonadJS (JSCtx_JavaScriptCore x) (WithWebView x IO) where
366443 jsContext <- askJSContext
367444 liftIO $ jsvaluetonumber jsContext val nullPtr --TODO: Exceptions
368445 mkJSFun a = do
369− wv <- askWebView
370446 jsContext <- askJSContext
371447 cb <- liftIO $ mkJSObjectCallAsFunctionCallback $ \_ _ _ argc argv _ -> do --TODO: Use the exception pointer to handle haskell exceptions
372448 args <- forM [0..fromIntegral (argc-1)] $ \n -> do
373449 x <- peekElemOff argv n
374450 jsvalueprotect jsContext x
375451 return $ JSRef_JavaScriptCore x --TODO: Unprotect eventually
376− unJSRef_JavaScriptCore <$> runWithWebView (a args) wv
452+ unJSRef_JavaScriptCore <$> runWithJSContext (a args) jsContext
377453 cbRef <- liftIO $ jsobjectmakefunctionwithcallback jsContext nullPtr cb
378454 liftIO $ jsvalueprotect jsContext cbRef
379455 return $ JSFun $ JSRef_JavaScriptCore cbRef
src/Reflex/Dom.hs+1−3
@@ -3,14 +3,12 @@ module Reflex.Dom (module X) where
33import Reflex as X
44import Reflex.Dom.Builder.Class as X
55import Reflex.Dom.Builder.Immediate as X
6+import Reflex.Dom.Builder.InputDisabled as X
67import Reflex.Dom.Builder.Static as X
78import Reflex.Dom.Class as X
8−import Reflex.Dom.DynamicWriter as X
99import Reflex.Dom.Internal as X
1010import Reflex.Dom.Location as X
1111import Reflex.Dom.Old as X
12−import Reflex.Dom.PerformEvent.Class as X
13−import Reflex.Dom.PostBuild.Class as X
1412import Reflex.Dom.Time as X
1513import Reflex.Dom.WebSocket as X
1614import Reflex.Dom.Widget as X
src/Reflex/Dom/Builder/Class.hs+215−27
@@ -10,6 +10,7 @@
1010{-# LANGUAGE OverloadedStrings #-}
1111{-# LANGUAGE PolyKinds #-}
1212{-# LANGUAGE RankNTypes #-}
13+{-# LANGUAGE RecursiveDo #-}
1314{-# LANGUAGE ScopedTypeVariables #-}
1415{-# LANGUAGE TemplateHaskell #-}
1516{-# LANGUAGE TypeFamilies #-}
@@ -17,23 +18,32 @@
1718module Reflex.Dom.Builder.Class
1819 ( module Reflex.Dom.Builder.Class
1920 , module Reflex.Dom.Builder.Class.Events
20− , module Reflex.Dom.Deletable.Class
21+ , module Reflex.Deletable.Class
2122 ) where
2223
23−import Reflex
24+import Reflex.Class as Reflex
2425import Reflex.Dom.Builder.Class.Events
25−import Reflex.Dom.Deletable.Class
26+import Reflex.Deletable.Class
27+import Reflex.DynamicWriter
28+import Reflex.PerformEvent.Class
29+import Reflex.PostBuild.Class
2630
2731import qualified Control.Category
2832import Control.Lens hiding (element)
2933import Control.Monad.Reader
34+import Control.Monad.State.Strict
3035import Control.Monad.Trans.Control
3136import Data.Default
37+import Data.Foldable
3238import Data.Functor.Misc
39+import Data.List.NonEmpty (NonEmpty, nonEmpty)
3340import Data.Map (Map)
41+import qualified Data.Map as Map
3442import Data.Proxy
3543import Data.Semigroup
44+import Data.String
3645import Data.Text (Text)
46+import Data.Traversable
3747import Data.Type.Coercion
3848import GHC.Exts (Constraint)
3949
@@ -43,19 +53,97 @@ class Default (EventSpec d EventResult) => DomSpace d where
4353 type RawElement d :: *
4454 type RawInputElement d :: *
4555 type RawTextAreaElement d :: *
56+ type RawSelectElement d :: *
57+ addEventSpecFlags :: proxy d -> EventName en -> (Maybe (er en) -> EventFlags) -> EventSpec d er -> EventSpec d er
4658
47−-- | @'DomBuilder' t m@ indicates that @m@ is a 'Monad' capable of building dynamic DOM in the 'Reflex' timeline @t@
59+{-# INLINABLE liftElementConfig #-}
60+liftElementConfig :: (DomBuilderSpace (f m) ~ DomBuilderSpace m) => ElementConfig er t (f m) -> ElementConfig er t m
61+liftElementConfig cfg = cfg
62+ { _elementConfig_eventSpec = _elementConfig_eventSpec cfg
63+ }
64+
65+-- | @'DomBuilder' t m@ indicates that @m@ is a 'Monad' capable of building
66+-- dynamic DOM in the 'Reflex' timeline @t@
4867class (Monad m, Reflex t, Deletable t m, DomSpace (DomBuilderSpace m)) => DomBuilder t m | m -> t where
4968 type DomBuilderSpace m :: *
5069 textNode :: TextNodeConfig t -> m (TextNode (DomBuilderSpace m) t)
70+ default textNode :: ( MonadTrans f
71+ , m ~ f m'
72+ , DomBuilderSpace m' ~ DomBuilderSpace m
73+ , DomBuilder t m'
74+ )
75+ => TextNodeConfig t -> m (TextNode (DomBuilderSpace m) t)
76+ textNode = lift . textNode
77+ {-# INLINABLE textNode #-}
5178 element :: Text -> ElementConfig er t m -> m a -> m (Element er (DomBuilderSpace m) t, a)
79+ default element :: ( MonadTransControl f
80+ , StT f a ~ a
81+ , m ~ f m'
82+ , DomBuilderSpace m' ~ DomBuilderSpace m
83+ , DomBuilder t m'
84+ )
85+ => Text -> ElementConfig er t m -> m a -> m (Element er (DomBuilderSpace m) t, a)
86+ element t cfg child = liftWith $ \run -> element t (liftElementConfig cfg) $ run child
87+ {-# INLINABLE element #-}
5288 -- | Create a placeholder in the DOM, with the ability to insert new DOM before it
5389 -- The provided DOM will be executed after the current frame, so it will not be affected by any occurrences that are concurrent with the occurrence that created it
5490 placeholder :: PlaceholderConfig above t m -> m (Placeholder above t)
5591 inputElement :: InputElementConfig er t m -> m (InputElement er (DomBuilderSpace m) t)
92+ default inputElement :: ( MonadTransControl f
93+ , m ~ f m'
94+ , DomBuilderSpace m' ~ DomBuilderSpace m
95+ , DomBuilder t m'
96+ )
97+ => InputElementConfig er t m -> m (InputElement er (DomBuilderSpace m) t)
98+ inputElement cfg = lift $ inputElement $ cfg
99+ { _inputElementConfig_elementConfig = liftElementConfig $ _inputElementConfig_elementConfig cfg
100+ }
101+ {-# INLINABLE inputElement #-}
56102 textAreaElement :: TextAreaElementConfig er t m -> m (TextAreaElement er (DomBuilderSpace m) t)
103+ default textAreaElement :: ( MonadTransControl f
104+ , m ~ f m'
105+ , DomBuilderSpace m' ~ DomBuilderSpace m
106+ , DomBuilder t m'
107+ )
108+ => TextAreaElementConfig er t m -> m (TextAreaElement er (DomBuilderSpace m) t)
109+ textAreaElement cfg = lift $ textAreaElement $ cfg
110+ { _textAreaElementConfig_elementConfig = liftElementConfig $ _textAreaElementConfig_elementConfig cfg
111+ }
112+ {-# INLINABLE textAreaElement #-}
113+ selectElement :: SelectElementConfig er t m -> m a -> m (SelectElement er (DomBuilderSpace m) t, a)
114+ default selectElement :: ( MonadTransControl f
115+ , StT f a ~ a
116+ , m ~ f m'
117+ , DomBuilderSpace m' ~ DomBuilderSpace m
118+ , DomBuilder t m'
119+ )
120+ => SelectElementConfig er t m -> m a -> m (SelectElement er (DomBuilderSpace m) t, a)
121+ selectElement cfg child = do
122+ let cfg' = cfg
123+ { _selectElementConfig_elementConfig = liftElementConfig $ _selectElementConfig_elementConfig cfg
124+ }
125+ liftWith $ \run -> selectElement cfg' $ run child
126+ {-# INLINABLE selectElement #-}
57127 placeRawElement :: RawElement (DomBuilderSpace m) -> m ()
128+ default placeRawElement :: ( MonadTrans f
129+ , m ~ f m'
130+ , DomBuilderSpace m' ~ DomBuilderSpace m
131+ , DomBuilder t m'
132+ )
133+ => RawElement (DomBuilderSpace m) -> m ()
134+ placeRawElement = lift . placeRawElement
135+ {-# INLINABLE placeRawElement #-}
58136 wrapRawElement :: RawElement (DomBuilderSpace m) -> RawElementConfig er t m -> m (Element er (DomBuilderSpace m) t)
137+ default wrapRawElement :: ( MonadTrans f
138+ , m ~ f m'
139+ , DomBuilderSpace m' ~ DomBuilderSpace m
140+ , DomBuilder t m'
141+ )
142+ => RawElement (DomBuilderSpace m) -> RawElementConfig er t m -> m (Element er (DomBuilderSpace m) t)
143+ wrapRawElement e cfg = lift $ wrapRawElement e $ cfg
144+ { _rawElementConfig_eventSpec = _rawElementConfig_eventSpec cfg
145+ }
146+ {-# INLINABLE wrapRawElement #-}
59147
60148type Namespace = Text
61149
@@ -75,7 +163,11 @@ data TextNode d t = TextNode
75163 { _textNode_raw :: RawTextNode d
76164 }
77165
78−type AttributeName = (Maybe Namespace, Text)
166+data AttributeName = AttributeName !(Maybe Namespace) !Text deriving (Show, Read, Eq, Ord)
167+
168+-- | By default, AttributeNames are unnamespaced
169+instance IsString AttributeName where
170+ fromString = AttributeName Nothing . fromString
79171
80172data Propagation
81173 = Propagation_Continue
@@ -121,15 +213,6 @@ data ElementConfig er t m
121213 , _elementConfig_eventSpec :: EventSpec (DomBuilderSpace m) er
122214 }
123215
124−instance (Reflex t, er ~ EventResult, DomBuilder t m) => Default (ElementConfig er t m) where
125− {-# INLINABLE def #-}
126− def = ElementConfig
127− { _elementConfig_namespace = Nothing
128− , _elementConfig_initialAttributes = mempty
129− , _elementConfig_modifyAttributes = never
130− , _elementConfig_eventSpec = def
131− }
132−
133216data Element er d t
134217 = Element { _element_events :: EventSelector t (WrapArg er EventName) --TODO: EventSelector should have two arguments
135218 , _element_raw :: RawElement d
@@ -219,12 +302,36 @@ instance (Reflex t, DomSpace (DomBuilderSpace m)) => Default (RawElementConfig E
219302 , _rawElementConfig_eventSpec = def
220303 }
221304
222−makeLenses ''TextNodeConfig
223−makeLenses ''ElementConfig
224−makeLenses ''PlaceholderConfig
225−makeLenses ''InputElementConfig
226−makeLenses ''TextAreaElementConfig
227−makeLenses ''RawElementConfig
305+data SelectElementConfig er t m = SelectElementConfig
306+ { _selectElementConfig_initialValue :: Text
307+ , _selectElementConfig_setValue :: Event t Text
308+ , _selectElementConfig_elementConfig :: ElementConfig er t m
309+ }
310+
311+instance (Reflex t, er ~ EventResult, DomBuilder t m) => Default (SelectElementConfig er t m) where
312+ def = SelectElementConfig
313+ { _selectElementConfig_initialValue = ""
314+ , _selectElementConfig_setValue = never
315+ , _selectElementConfig_elementConfig = def
316+ }
317+
318+data SelectElement er d t = SelectElement
319+ { _selectElement_element :: Element er d t
320+ , _selectElement_value :: Dynamic t Text
321+ , _selectElement_change :: Event t Text -- ^ Fires when the value is changed by the user, but not when it is set by setValue
322+ , _selectElement_hasFocus :: Dynamic t Bool
323+ , _selectElement_raw :: RawSelectElement d
324+ }
325+
326+concat <$> mapM makeLenses
327+ [ ''TextNodeConfig
328+ , ''ElementConfig
329+ , ''PlaceholderConfig
330+ , ''InputElementConfig
331+ , ''TextAreaElementConfig
332+ , ''SelectElementConfig
333+ , ''RawElementConfig
334+ ]
228335
229336class CanDeleteSelf t a | a -> t where
230337 deleteSelf :: Lens' a (Event t ())
@@ -246,6 +353,14 @@ instance InitialAttributes (ElementConfig er t m) where
246353 {-# INLINABLE initialAttributes #-}
247354 initialAttributes = elementConfig_initialAttributes
248355
356+instance InitialAttributes (InputElementConfig er t m) where
357+ {-# INLINABLE initialAttributes #-}
358+ initialAttributes = inputElementConfig_elementConfig . elementConfig_initialAttributes
359+
360+instance InitialAttributes (TextAreaElementConfig er t m) where
361+ {-# INLINABLE initialAttributes #-}
362+ initialAttributes = textAreaElementConfig_elementConfig . elementConfig_initialAttributes
363+
249364class ModifyAttributes t a | a -> t where
250365 modifyAttributes :: Lens' a (Event t (Map AttributeName (Maybe Text)))
251366
@@ -253,6 +368,14 @@ instance ModifyAttributes t (ElementConfig er t m) where
253368 {-# INLINABLE modifyAttributes #-}
254369 modifyAttributes = elementConfig_modifyAttributes
255370
371+instance ModifyAttributes t (InputElementConfig er t m) where
372+ {-# INLINABLE modifyAttributes #-}
373+ modifyAttributes = inputElementConfig_elementConfig . elementConfig_modifyAttributes
374+
375+instance ModifyAttributes t (TextAreaElementConfig er t m) where
376+ {-# INLINABLE modifyAttributes #-}
377+ modifyAttributes = textAreaElementConfig_elementConfig . elementConfig_modifyAttributes
378+
256379instance ModifyAttributes t (RawElementConfig er t m) where
257380 {-# INLINABLE modifyAttributes #-}
258381 modifyAttributes = rawElementConfig_modifyAttributes
@@ -264,6 +387,74 @@ instance HasNamespace (ElementConfig er t m) where
264387 {-# INLINABLE namespace #-}
265388 namespace = elementConfig_namespace
266389
390+instance (Reflex t, er ~ EventResult, DomBuilder t m) => Default (ElementConfig er t m) where
391+ {-# INLINABLE def #-}
392+ def = ElementConfig
393+ { _elementConfig_namespace = Nothing
394+ , _elementConfig_initialAttributes = mempty
395+ , _elementConfig_modifyAttributes = never
396+ , _elementConfig_eventSpec = def
397+ }
398+
399+instance (DomBuilder t m, PerformEvent t m, MonadFix m, MonadHold t m) => DomBuilder t (PostBuildT t m) where
400+ type DomBuilderSpace (PostBuildT t m) = DomBuilderSpace m
401+ {-# INLINABLE placeholder #-}
402+ placeholder cfg = lift $ do
403+ rec childPostBuild <- deletable (_placeholder_deletedSelf p) $ performEvent $ return () <$ _placeholder_insertedAbove p
404+ p <- placeholder $ cfg
405+ { _placeholderConfig_insertAbove = ffor (_placeholderConfig_insertAbove cfg) $ \a -> runPostBuildT a =<< headE childPostBuild
406+ }
407+ return p
408+ wrapRawElement e cfg = liftWith $ \run -> wrapRawElement e $ fmap1 run cfg
409+
410+instance (DomBuilder t m, Monoid w, MonadHold t m, MonadFix m) => DomBuilder t (DynamicWriterT t w m) where
411+ type DomBuilderSpace (DynamicWriterT t w m) = DomBuilderSpace m
412+ textNode = liftTextNode
413+ element elementTag cfg (DynamicWriterT child) = DynamicWriterT $ do
414+ s <- get
415+ let cfg' = liftElementConfig cfg
416+ (el, (a, newS)) <- lift $ element elementTag cfg' $ runStateT child s
417+ put newS
418+ return (el, a)
419+ placeholder cfg = do
420+ let cfg' = cfg
421+ { _placeholderConfig_insertAbove = runDynamicWriterTInternal <$> _placeholderConfig_insertAbove cfg
422+ }
423+ let manageChildren :: Event t (NonEmpty (Replaceable t (Dynamic t w))) -- ^ Add nodes on the right; these are in reverse order
424+ -> Event t () -- ^ No more nodes will be added after this event fires
425+ -> m (Replaceable t (Dynamic t w))
426+ manageChildren newChildren additionsCeased = do
427+ rec nextId <- hold (0 :: Int) newNextId -- We assume this will never wrap around
428+ let numberedNewChildren :: Event t (Int, PatchMap (Map Int (Replaceable t (Dynamic t w))))
429+ numberedNewChildren = flip pushAlways newChildren $ \rcs -> do
430+ let cs = reverse $ toList rcs
431+ myFirstId <- sample nextId
432+ let (myNextId, numbered) = mapAccumL (\n v -> (succ n, (n, Just v))) myFirstId cs
433+ return (myNextId, PatchMap $ Map.fromList numbered)
434+ newNextId = fst <$> numberedNewChildren
435+ mconcatIncrementalReplaceableDynMap Map.empty (snd <$> numberedNewChildren) additionsCeased
436+ rec children <- lift $ manageChildren childOutputs $ cfg ^. deleteSelf
437+ p <- DynamicWriterT $ do
438+ modify (children:)
439+ lift $ placeholder cfg'
440+ let result = fst <$> _placeholder_insertedAbove p
441+ childOutputs = fmapMaybe (nonEmpty . snd) $ _placeholder_insertedAbove p
442+ return $ p
443+ { _placeholder_insertedAbove = result
444+ }
445+ inputElement cfg = lift $ inputElement $ cfg & inputElementConfig_elementConfig %~ liftElementConfig
446+ textAreaElement cfg = lift $ textAreaElement $ cfg & textAreaElementConfig_elementConfig %~ liftElementConfig
447+ selectElement cfg (DynamicWriterT child) = DynamicWriterT $ do
448+ s <- get
449+ let cfg' = cfg & selectElementConfig_elementConfig %~ liftElementConfig
450+ (el, (a, newS)) <- lift $ selectElement cfg' $ runStateT child s
451+ put newS
452+ return (el, a)
453+ placeRawElement = lift . placeRawElement
454+ wrapRawElement e cfg = lift $ wrapRawElement e $ cfg
455+ { _rawElementConfig_eventSpec = _rawElementConfig_eventSpec cfg
456+ }
457+
267458-- * Convenience functions
268459
269460--TODO: Move/replace
@@ -293,6 +484,10 @@ instance Functor1 (TextAreaElementConfig er t) where
293484 type Functor1Constraint (TextAreaElementConfig er t) a b = Functor1Constraint (ElementConfig er t) a b
294485 fmap1 f cfg = cfg & textAreaElementConfig_elementConfig %~ fmap1 f
295486
487+instance Functor1 (SelectElementConfig er t) where
488+ type Functor1Constraint (SelectElementConfig er t) a b = Functor1Constraint (ElementConfig er t) a b
489+ fmap1 f cfg = cfg & selectElementConfig_elementConfig %~ fmap1 f
490+
296491instance Functor1 (RawElementConfig er t) where
297492 type Functor1Constraint (RawElementConfig er t) a b = DomBuilderSpace a ~ DomBuilderSpace b
298493 {-# INLINABLE fmap1 #-}
@@ -321,14 +516,7 @@ instance Reflex t => HasDomEvent t (TextAreaElement EventResult d t) en where
321516
322517instance DomBuilder t m => DomBuilder t (ReaderT r m) where
323518 type DomBuilderSpace (ReaderT r m) = DomBuilderSpace m
324− {-# INLINABLE textNode #-}
325− textNode = liftTextNode
326− element = liftElement
327519 placeholder = liftPlaceholder
328− inputElement = liftInputElement
329− textAreaElement = liftTextAreaElement
330− placeRawElement = lift . placeRawElement
331− wrapRawElement = liftWrapRawElement
332520
333521type LiftDomBuilder t f m =
334522 ( Reflex t
src/Reflex/Dom/Builder/Immediate.hs+57−11
@@ -17,10 +17,11 @@
1717module Reflex.Dom.Builder.Immediate where
1818
1919import Foreign.JavaScript.TH
20−import Reflex
20+import Reflex.Class as Reflex
21+import Reflex.Dynamic
2122import Reflex.Dom.Builder.Class
22−import Reflex.Dom.PerformEvent.Class
23−import Reflex.Dom.PostBuild.Class
23+import Reflex.PerformEvent.Class
24+import Reflex.PostBuild.Class
2425import Reflex.Host.Class
2526
2627import Control.Concurrent.Chan
@@ -37,6 +38,7 @@ import Data.Dependent.Sum
3738import Data.Functor.Misc
3839import Data.IORef
3940import Data.Maybe
41+import Data.Monoid
4042import Data.Text (Text)
4143import GHCJS.DOM.Document (Document, createDocumentFragment, createElement, createElementNS, createTextNode)
4244import GHCJS.DOM.Element (getScrollTop, removeAttribute, removeAttributeNS, setAttribute, setAttributeNS)
@@ -45,12 +47,14 @@ import qualified GHCJS.DOM.Event as Event
4547import GHCJS.DOM.EventM (EventM, event, on)
4648import qualified GHCJS.DOM.EventM as DOM
4749import qualified GHCJS.DOM.HTMLInputElement as Input
50+import qualified GHCJS.DOM.HTMLSelectElement as Select
4851import qualified GHCJS.DOM.HTMLTextAreaElement as TextArea
4952import GHCJS.DOM.MouseEvent
5053import GHCJS.DOM.Node (appendChild, getOwnerDocument, getParentNode, getPreviousSibling, insertBefore,
5154 removeChild, setNodeValue, toNode)
5255import GHCJS.DOM.Types (FocusEvent, IsElement, IsEvent, IsNode, KeyboardEvent, Node, ToDOMString, TouchEvent,
53− WheelEvent, castToHTMLInputElement, castToHTMLTextAreaElement)
56+ WheelEvent, castToHTMLInputElement, castToHTMLSelectElement,
57+ castToHTMLTextAreaElement)
5458import qualified GHCJS.DOM.Types as DOM
5559import GHCJS.DOM.UIEvent
5660import qualified GHCJS.DOM.Window as Window
@@ -131,7 +135,7 @@ newtype EventFilterTriggerRef t er (en :: EventTag) = EventFilterTriggerRef (IOR
131135wrap :: forall m er t. SupportsImmediateDomBuilder t m => RawElement GhcjsDomSpace -> RawElementConfig er t (ImmediateDomBuilderT t m) -> ImmediateDomBuilderT t m (Element er GhcjsDomSpace t)
132136wrap e cfg = do
133137 events <- askEvents
134− lift $ performEvent_ $ ffor (cfg ^. modifyAttributes) $ imapM_ $ \(mAttrNamespace, n) mv -> case mAttrNamespace of
138+ lift $ performEvent_ $ ffor (cfg ^. modifyAttributes) $ imapM_ $ \(AttributeName mAttrNamespace n) mv -> case mAttrNamespace of
135139 Nothing -> maybe (removeAttribute e n) (setAttribute e n) mv
136140 Just ns -> maybe (removeAttributeNS e (Just ns) n) (setAttributeNS e (Just ns) n) mv
137141 eventTriggerRefs :: DMap EventName (EventFilterTriggerRef t er) <- liftIO $ fmap DMap.fromList $ forM (DMap.toList $ _ghcjsEventSpec_filters $ _rawElementConfig_eventSpec cfg) $ \(en :=> GhcjsEventFilter f) -> do
@@ -173,7 +177,7 @@ makeElement elementTag cfg child = do
173177 Just e <- ImmediateDomBuilderT $ fmap DOM.castToHTMLElement <$> case cfg ^. namespace of
174178 Nothing -> createElement doc (Just elementTag)
175179 Just ens -> createElementNS doc (Just ens) (Just elementTag)
176− ImmediateDomBuilderT $ iforM_ (cfg ^. initialAttributes) $ \(mAttrNamespace, n) v -> case mAttrNamespace of
180+ ImmediateDomBuilderT $ iforM_ (cfg ^. initialAttributes) $ \(AttributeName mAttrNamespace n) v -> case mAttrNamespace of
177181 Nothing -> setAttribute e n v
178182 Just ans -> setAttributeNS e (Just ans) n v
179183 result <- lift $ runImmediateDomBuilderT child $ ImmediateDomBuilderEnv
@@ -199,6 +203,20 @@ instance DomSpace GhcjsDomSpace where
199203 type RawElement GhcjsDomSpace = DOM.HTMLElement
200204 type RawInputElement GhcjsDomSpace = DOM.HTMLInputElement
201205 type RawTextAreaElement GhcjsDomSpace = DOM.HTMLTextAreaElement
206+ type RawSelectElement GhcjsDomSpace = DOM.HTMLSelectElement
207+ addEventSpecFlags _ en f es = es
208+ { _ghcjsEventSpec_filters =
209+ let f' = Just . GhcjsEventFilter . \case
210+ Nothing -> \evt -> do
211+ mEventResult <- _ghcjsEventSpec_handler es (en, evt)
212+ return (f mEventResult, return mEventResult)
213+ Just (GhcjsEventFilter oldFilter) -> \evt -> do
214+ (oldFlags, oldContinuation) <- oldFilter evt
215+ mEventResult <- oldContinuation
216+ let newFlags = oldFlags <> f mEventResult
217+ return (newFlags, return mEventResult)
218+ in DMap.alter f' en $ _ghcjsEventSpec_filters es
219+ }
202220
203221newtype GhcjsEventFilter er en = GhcjsEventFilter (GhcjsDomEvent en -> IO (EventFlags, IO (Maybe (er en))))
204222
@@ -294,11 +312,7 @@ instance SupportsImmediateDomBuilder t m => DomBuilder t (ImmediateDomBuilderT t
294312 [ valueChangedBySetValue
295313 , valueChangedByUI
296314 ]
297− let initialFocus = False --TODO: Is this correct?
298− hasFocus <- holdDyn initialFocus $ leftmost
299− [ False <$ Reflex.select (_element_events e) (WrapArg Blur)
300− , True <$ Reflex.select (_element_events e) (WrapArg Focus)
301− ]
315+ hasFocus <- mkHasFocus e
302316 return $ TextAreaElement
303317 { _textAreaElement_value = v
304318 , _textAreaElement_input = valueChangedByUI
@@ -306,9 +320,41 @@ instance SupportsImmediateDomBuilder t m => DomBuilder t (ImmediateDomBuilderT t
306320 , _textAreaElement_element = e
307321 , _textAreaElement_raw = domTextAreaElement
308322 }
323+ {-# INLINABLE selectElement #-}
324+ selectElement cfg child = do
325+ ((e, result), domElement) <- makeElement "select" (cfg ^. selectElementConfig_elementConfig) child
326+ let domSelectElement = castToHTMLSelectElement domElement
327+ Select.setValue domSelectElement $ Just (cfg ^. selectElementConfig_initialValue)
328+ Just v0 <- Select.getValue domSelectElement
329+ let getMyValue = fromMaybe "" <$> Select.getValue domSelectElement
330+ valueChangedByUI <- performEvent $ getMyValue <$ Reflex.select (_element_events e) (WrapArg Change)
331+ valueChangedBySetValue <- performEvent $ ffor (cfg ^. selectElementConfig_setValue) $ \v' -> do
332+ Select.setValue domSelectElement $ Just v'
333+ getMyValue -- We get the value after setting it in case the browser has mucked with it somehow
334+ v <- holdDyn v0 $ leftmost
335+ [ valueChangedBySetValue
336+ , valueChangedByUI
337+ ]
338+ hasFocus <- mkHasFocus e
339+ let wrapped = SelectElement
340+ { _selectElement_value = v
341+ , _selectElement_change = valueChangedByUI
342+ , _selectElement_hasFocus = hasFocus
343+ , _selectElement_element = e
344+ , _selectElement_raw = domSelectElement
345+ }
346+ return (wrapped, result)
309347 placeRawElement = append
310348 wrapRawElement = wrap
311349
350+mkHasFocus :: (MonadHold t m, Reflex t) => Element er d t -> m (Dynamic t Bool)
351+mkHasFocus e = do
352+ let initialFocus = False --TODO: Actually get the initial focus of the element
353+ holdDyn initialFocus $ leftmost
354+ [ False <$ Reflex.select (_element_events e) (WrapArg Blur)
355+ , True <$ Reflex.select (_element_events e) (WrapArg Focus)
356+ ]
357+
312358{-# INLINABLE insertImmediateAbove #-}
313359insertImmediateAbove :: (Reflex t, IsNode placeholder, PerformEvent t m, MonadIO (Performable m)) => placeholder -> Event t (ImmediateDomBuilderT t (Performable m) a) -> ImmediateDomBuilderT t m (Event t a)
314360insertImmediateAbove n toInsertAbove = do
src/Reflex/Dom/Builder/InputDisabled.hsnew file+90
@@ -0,0 +1,90 @@
1+{-# LANGUAGE StandaloneDeriving #-}
2+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3+{-# LANGUAGE OverloadedStrings #-}
4+{-# LANGUAGE TypeFamilies #-}
5+{-# LANGUAGE MultiParamTypeClasses #-}
6+{-# LANGUAGE FlexibleInstances #-}
7+{-# LANGUAGE UndecidableInstances #-}
8+module Reflex.Dom.Builder.InputDisabled where
9+
10+import Control.Lens
11+import Control.Monad.Fix
12+import Control.Monad.Ref
13+import Control.Monad.Trans
14+import Control.Monad.Trans.Control
15+import qualified Data.Map as Map
16+import Foreign.JavaScript.TH
17+import Reflex
18+import Reflex.Deletable.Class
19+import Reflex.Dom.Builder.Class
20+import Reflex.Host.Class
21+
22+-- | A DomBuilder transformer that disables all 'inputElement's,
23+-- 'textAreaElement's, and 'selectElement's by adding the "disabled" HTML
24+-- attribute. Note that 'element's that happen to have "input", "textarea", or
25+-- "select" as their tag will NOT be disabled.
26+newtype InputDisabledT m a = InputDisabledT { runInputDisabledT :: m a } deriving (Functor, Applicative, Monad, MonadAtomicRef, MonadFix, MonadIO)
27+
28+deriving instance MonadSample t m => MonadSample t (InputDisabledT m)
29+deriving instance MonadHold t m => MonadHold t (InputDisabledT m)
30+
31+instance MonadTrans InputDisabledT where
32+ lift = InputDisabledT
33+
34+instance MonadTransControl InputDisabledT where
35+ type StT InputDisabledT a = a
36+ liftWith f = InputDisabledT $ f runInputDisabledT
37+ restoreT = InputDisabledT
38+
39+instance MonadRef m => MonadRef (InputDisabledT m) where
40+ type Ref (InputDisabledT m) = Ref m
41+ newRef = lift . newRef
42+ readRef = lift . readRef
43+ writeRef ref = lift . writeRef ref
44+
45+instance PerformEvent t m => PerformEvent t (InputDisabledT m) where
46+ type Performable (InputDisabledT m) = Performable m
47+ performEvent_ = lift . performEvent_
48+ performEvent = lift . performEvent
49+
50+disableElementConfig :: Reflex t => ElementConfig er t m -> ElementConfig er t m
51+disableElementConfig cfg = cfg
52+ { _elementConfig_initialAttributes = Map.insert "disabled" "disabled" $ _elementConfig_initialAttributes cfg
53+ , _elementConfig_modifyAttributes = Map.delete "disabled" <$> _elementConfig_modifyAttributes cfg
54+ }
55+
56+instance Deletable t m => Deletable t (InputDisabledT m) where
57+ deletable d = liftThrough $ deletable d
58+
59+instance PostBuild t m => PostBuild t (InputDisabledT m) where
60+ getPostBuild = lift getPostBuild
61+
62+deriving instance TriggerEvent t m => TriggerEvent t (InputDisabledT m)
63+
64+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (InputDisabledT m) where
65+ newEventWithTrigger = lift . newEventWithTrigger
66+ newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
67+
68+instance DomBuilder t m => DomBuilder t (InputDisabledT m) where
69+ type DomBuilderSpace (InputDisabledT m) = DomBuilderSpace m
70+ placeholder cfg = lift $ placeholder $ cfg
71+ & placeholderConfig_insertAbove %~ fmap runInputDisabledT
72+ inputElement cfg = lift $ inputElement $ cfg
73+ { _inputElementConfig_elementConfig = liftElementConfig $ disableElementConfig $ _inputElementConfig_elementConfig cfg
74+ }
75+ textAreaElement cfg = lift $ textAreaElement $ cfg
76+ { _textAreaElementConfig_elementConfig = liftElementConfig $ disableElementConfig $ _textAreaElementConfig_elementConfig cfg
77+ }
78+ selectElement cfg child = do
79+ let cfg' = cfg
80+ { _selectElementConfig_elementConfig = liftElementConfig $ disableElementConfig $ _selectElementConfig_elementConfig cfg
81+ }
82+ lift $ selectElement cfg' $ runInputDisabledT child
83+
84+instance HasWebView m => HasWebView (InputDisabledT m) where
85+ type WebViewPhantom (InputDisabledT m) = WebViewPhantom m
86+ askWebView = lift askWebView
87+
88+instance HasJS js m => HasJS js (InputDisabledT m) where
89+ type JSM (InputDisabledT m) = JSM m
90+ liftJS = lift . liftJS
src/Reflex/Dom/Builder/Static.hs+29−5
@@ -32,13 +32,15 @@ import qualified Data.Map as Map
3232import Data.Monoid
3333import Data.Text.Encoding
3434import GHC.Generics
35−import Reflex
35+import Reflex.Class
3636import Reflex.Dom.Builder.Class
37−import Reflex.Dom.PerformEvent.Base
38−import Reflex.Dom.PerformEvent.Class
39−import Reflex.Dom.PostBuild.Class
4037import Reflex.Dom.Widget.Basic (applyMap)
38+import Reflex.Dynamic
4139import Reflex.Host.Class
40+import Reflex.PerformEvent.Base
41+import Reflex.PerformEvent.Class
42+import Reflex.PostBuild.Class
43+import Reflex.Spider
4244
4345
4446newtype StaticDomBuilderT t m a = StaticDomBuilderT
@@ -101,6 +103,15 @@ instance (Monad m, Ref m ~ Ref IO, Reflex t) => TriggerEvent t (StaticDomBuilder
101103 {-# INLINABLE newEventWithLazyTriggerWithOnComplete #-}
102104 newEventWithLazyTriggerWithOnComplete _ = return never
103105
106+instance MonadRef m => MonadRef (StaticDomBuilderT t m) where
107+ type Ref (StaticDomBuilderT t m) = Ref m
108+ newRef = lift . newRef
109+ readRef = lift . readRef
110+ writeRef r = lift . writeRef r
111+
112+instance MonadAtomicRef m => MonadAtomicRef (StaticDomBuilderT t m) where
113+ atomicModifyRef r = lift . atomicModifyRef r
114+
104115type SupportsStaticDomBuilder t m = (Reflex t, MonadIO m, MonadHold t m, MonadFix m, PerformEvent t m, Performable m ~ m, MonadReflexCreateTrigger t m, Deletable t m, MonadRef m, Ref m ~ Ref IO)
105116
106117data StaticDomSpace
@@ -121,6 +132,8 @@ instance DomSpace StaticDomSpace where
121132 type RawElement StaticDomSpace = ()
122133 type RawInputElement StaticDomSpace = ()
123134 type RawTextAreaElement StaticDomSpace = ()
135+ type RawSelectElement StaticDomSpace = ()
136+ addEventSpecFlags _ _ _ _ = StaticEventSpec
124137
125138instance SupportsStaticDomBuilder t m => DomBuilder t (StaticDomBuilderT t m) where
126139 type DomBuilderSpace (StaticDomBuilderT t m) = StaticDomSpace
@@ -132,7 +145,7 @@ instance SupportsStaticDomBuilder t m => DomBuilder t (StaticDomBuilderT t m) wh
132145 return $ TextNode ()
133146 {-# INLINABLE element #-}
134147 element elementTag cfg child = do
135− let toAttr (_mns, k) v = encodeUtf8 k <> "=\"" <> BL.toStrict (toLazyByteString $ fromHtmlEscapedText v) <> "\""
148+ let toAttr (AttributeName _mns k) v = encodeUtf8 k <> "=\"" <> BL.toStrict (toLazyByteString $ fromHtmlEscapedText v) <> "\""
136149 es <- newFanEventWithTrigger $ \_ _ -> return (return ())
137150 StaticDomBuilderT $ do
138151 (result, innerHtml) <- lift $ runStaticDomBuilderT child
@@ -177,6 +190,17 @@ instance SupportsStaticDomBuilder t m => DomBuilder t (StaticDomBuilderT t m) wh
177190 , _textAreaElement_element = e
178191 , _textAreaElement_raw = ()
179192 }
193+ selectElement cfg child = do
194+ (e, result) <- element "select" (_selectElementConfig_elementConfig cfg) child
195+ v <- holdDyn (cfg ^. selectElementConfig_initialValue) (cfg ^. selectElementConfig_setValue)
196+ let wrapped = SelectElement
197+ { _selectElement_value = v
198+ , _selectElement_change = never
199+ , _selectElement_hasFocus = constDyn False --TODO: How do we make sure this is correct?
200+ , _selectElement_element = e
201+ , _selectElement_raw = ()
202+ }
203+ return (wrapped, result)
180204 placeRawElement () = return ()
181205 wrapRawElement () _ = return $ Element (EventSelector $ const never) ()
182206
src/Reflex/Dom/Class.hs+2−2
@@ -10,8 +10,8 @@ import Reflex.Class
1010import Web.KeyCode
1111
1212import Foreign.JavaScript.TH
13−import Reflex.Dom.PerformEvent.Class
14−import Reflex.Dom.PostBuild.Class
13+import Reflex.PerformEvent.Class
14+import Reflex.PostBuild.Class
1515
1616import Prelude hiding (concat, mapM, mapM_, sequence)
1717
src/Reflex/Dom/Deletable/Class.hsdeleted−17
@@ -1,17 +0,0 @@
1−{-# LANGUAGE FlexibleInstances #-}
2−{-# LANGUAGE FunctionalDependencies #-}
3−{-# LANGUAGE MultiParamTypeClasses #-}
4−{-# LANGUAGE UndecidableInstances #-}
5−module Reflex.Dom.Deletable.Class where
6−
7−import Reflex
8−
9−import Control.Monad.Reader
10−import Control.Monad.Trans.Control
11−
12−class (Reflex t, Monad m) => Deletable t m | m -> t where
13− deletable :: Event t () -> m a -> m a
14−
15−instance Deletable t m => Deletable t (ReaderT r m) where
16− {-# INLINABLE deletable #-}
17− deletable = liftThrough . deletable
src/Reflex/Dom/DynamicWriter.hsdeleted−241
@@ -1,241 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE FlexibleInstances #-}
3−{-# LANGUAGE FunctionalDependencies #-}
4−{-# LANGUAGE GADTs #-}
5−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
6−{-# LANGUAGE LambdaCase #-}
7−{-# LANGUAGE MultiParamTypeClasses #-}
8−{-# LANGUAGE RecursiveDo #-}
9−{-# LANGUAGE ScopedTypeVariables #-}
10−{-# LANGUAGE TypeFamilies #-}
11−{-# LANGUAGE UndecidableInstances #-}
12−module Reflex.Dom.DynamicWriter where
13−
14−import Control.Lens hiding (element)
15−import Control.Monad.Exception
16−import Control.Monad.IO.Class
17−import Control.Monad.Reader
18−import Control.Monad.Ref
19−import Control.Monad.State.Strict
20−import Data.Dependent.Map (DMap)
21−import Data.Foldable
22−import Data.Functor.Compose
23−import Data.Functor.Misc
24−import Data.List.NonEmpty (NonEmpty, nonEmpty)
25−import Data.Map (Map)
26−import qualified Data.Map as Map
27−import Data.Semigroup
28−import Data.Traversable
29−import Reflex
30−import Reflex.Dom.Builder.Class
31−import Reflex.Dom.Class
32−import Reflex.Dom.PerformEvent.Class
33−import Reflex.Dom.PostBuild.Class
34−import Reflex.Host.Class
35−
36−instance MonadTrans (DynamicWriterT t w) where
37− lift = DynamicWriterT . lift
38−
39−data PatchMap a where
40− PatchMap :: Ord k => Map k (Maybe v) -> PatchMap (Map k v)
41−
42−instance Patch PatchMap where
43− apply (PatchMap p) old = Just $! insertions `Map.union` (old `Map.difference` deletions) --TODO: return Nothing sometimes --Note: the strict application here is critical to ensuring that incremental merges don't hold onto all their prerequisite events forever; can we make this more robust?
44− where insertions = Map.mapMaybeWithKey (const id) p
45− deletions = Map.mapMaybeWithKey (const nothingToJust) p
46− nothingToJust = \case
47− Nothing -> Just ()
48− Just _ -> Nothing
49−
50−instance Ord k => Semigroup (PatchMap (Map k v)) where
51− PatchMap a <> PatchMap b = PatchMap $ a `mappend` b --TODO: Add a semigroup instance for Map
52− -- PatchMap is idempotent, so stimes n is id for every n
53−#if MIN_VERSION_semigroups(0,17,0)
54− stimes = stimesIdempotentMonoid
55−#else
56− times1p n x = case compare n 0 of
57− LT -> error "stimesIdempotentMonoid: negative multiplier"
58− EQ -> mempty
59− GT -> x
60−#endif
61−
62−instance Ord k => Monoid (PatchMap (Map k v)) where
63− mempty = PatchMap mempty
64− mappend = (<>)
65−
66−mconcatIncremental :: (Reflex t, MonadHold t m, MonadFix m, Monoid v) => Map k v -> Event t (PatchMap (Map k v)) -> m (Dynamic t v)
67−mconcatIncremental m0 e = do
68− d <- foldDynMaybe apply m0 e
69− return $ fmap (mconcat . Map.elems) d
70−
71−mapIncrementalMapValuesWithKey :: Reflex t => (k -> v -> v') -> Incremental t PatchMap (Map k v) -> Incremental t PatchMap (Map k v')
72−mapIncrementalMapValuesWithKey f = unsafeMapIncremental (Map.mapWithKey f) $ \(PatchMap m) -> PatchMap $ Map.mapWithKey (\k mv -> fmap (f k) mv) m
73−
74−mapIncrementalMapValues :: Reflex t => (v -> v') -> Incremental t PatchMap (Map k v) -> Incremental t PatchMap (Map k v')
75−mapIncrementalMapValues f = mapIncrementalMapValuesWithKey $ const f
76−
77−unsafeMapIncremental :: (Reflex t, Patch p, Patch p') => (a -> a') -> (p a -> p' a') -> Incremental t p a -> Incremental t p' a'
78−unsafeMapIncremental f g a = unsafeBuildIncremental (fmap f $ sample $ currentIncremental a) $ g <$> updatedIncremental a
79−
80−incrementalExtractFunctorDMap :: Reflex t => Incremental t PatchMap (Map k (f v)) -> Incremental t PatchDMap (DMap (Const2 k v) f)
81−incrementalExtractFunctorDMap = unsafeMapIncremental mapWithFunctorToDMap $ \(PatchMap m) -> PatchDMap $ mapWithFunctorToDMap $ fmap Compose m
82−
83−mergeIncrementalMap :: (Reflex t, Ord k) => Incremental t PatchMap (Map k (Event t v)) -> Event t (Map k v)
84−mergeIncrementalMap = fmap dmapToMap . mergeIncremental . incrementalExtractFunctorDMap
85−
86−holdIncrementalReplaceableMap :: forall t k v m. (MonadFix m, MonadHold t m, Reflex t, Ord k) => Map k (Replaceable t v) -> Event t (PatchMap (Map k (Replaceable t v))) -> m (Incremental t PatchMap (Map k v))
87−holdIncrementalReplaceableMap m0 m' = do
88− rec vals <- holdIncremental m0 $ m' <> valChanges
89− let valChanges = fmap PatchMap $ mergeIncrementalMap $ mapIncrementalMapValues _replaceable_modify vals
90− return $ mapIncrementalMapValues _replaceable_value vals
91−
92−mergeDynIncremental :: (Reflex t, Ord k) => Incremental t PatchMap (Map k (Dynamic t v)) -> Incremental t PatchMap (Map k v)
93−mergeDynIncremental a = unsafeBuildIncremental (mapM (sample . current) =<< sample (currentIncremental a)) $ addedAndRemovedValues <> changedValues
94− where changedValues = fmap (PatchMap . fmap Just) $ mergeIncrementalMap $ mapIncrementalMapValues updated a
95− addedAndRemovedValues = flip pushAlways (updatedIncremental a) $ \(PatchMap m) -> PatchMap <$> mapM (mapM (sample . current)) m
96−
97−data Replaceable t w = Replaceable
98− { _replaceable_value :: w
99− , _replaceable_modify :: Event t (Maybe (Replaceable t w)) -- "Please delete" is represented with an event of Nothing; all subsequent events will be ignored
100− }
101−
102−type DynamicWriterAccumulator t w = [Replaceable t (Dynamic t w)]
103−
104−newtype DynamicWriterT t w m a = DynamicWriterT { unDynamicWriterT :: StateT (DynamicWriterAccumulator t w) m a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadHold t, MonadSample t, MonadAsyncException, MonadException) -- The list is kept in reverse order
105−
106−instance HasWebView m => HasWebView (DynamicWriterT t w m) where
107− type WebViewPhantom (DynamicWriterT t w m) = WebViewPhantom m
108− askWebView = lift askWebView
109−
110−instance MonadRef m => MonadRef (DynamicWriterT t w m) where
111− type Ref (DynamicWriterT t w m) = Ref m
112− newRef = lift . newRef
113− readRef = lift . readRef
114− writeRef r = lift . writeRef r
115−
116−instance MonadAtomicRef m => MonadAtomicRef (DynamicWriterT t w m) where
117− atomicModifyRef r = lift . atomicModifyRef r
118−
119−instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (DynamicWriterT t w m) where
120− newEventWithTrigger = lift . newEventWithTrigger
121− newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
122−
123−runDynamicWriterTInternal :: DynamicWriterT t w m a -> m (a, DynamicWriterAccumulator t w)
124−runDynamicWriterTInternal (DynamicWriterT a) = runStateT a []
125−
126−mconcatIncrementalReplaceableDynMap :: forall m t k v. (MonadFix m, MonadHold t m, Reflex t, Monoid v, Ord k) => Map k (Replaceable t (Dynamic t v)) -> Event t (PatchMap (Map k (Replaceable t (Dynamic t v)))) -> Event t () -> m (Replaceable t (Dynamic t v))
127−mconcatIncrementalReplaceableDynMap m0 m' additionsCeased = do
128− rec vals <- holdIncremental m0 $ m' <> valChanges
129− let valChanges = fmap PatchMap $ mergeIncrementalMap $ mapIncrementalMapValues _replaceable_modify vals
130− let i = mapIncrementalMapValues _replaceable_value vals
131− noMoreAdditions <- holdDyn False $ True <$ additionsCeased
132− let replaceSelf nma x = do
133− guard nma
134− case Map.toList x of
135− [] -> return Nothing -- Delete self
136− [(_, n)] -> return $ Just n --TODO: What if this one is also replacing itself simultaneously?
137− _ -> mzero
138− result = fmap (mconcat . Map.elems) $ incrementalToDynamic $ mergeDynIncremental i
139− return $ Replaceable result $ fmapMaybe id $ updated $ zipDynWith replaceSelf noMoreAdditions $ incrementalToDynamic vals
140−
141−runDynamicWriterT :: (MonadFix m, Reflex t, MonadHold t m, Monoid w) => DynamicWriterT t w m a -> m (a, Dynamic t w)
142−runDynamicWriterT (DynamicWriterT a) = do
143− (result, ws) <- runStateT a []
144− Replaceable w _ <- mconcatIncrementalReplaceableDynMap (Map.fromList $ zip [1 :: Int ..] $ reverse ws) never never
145− return (result, w)
146−
147−class Monad m => MonadDynamicWriter t w m | m -> t w where
148− tellDyn :: Dynamic t w -> m ()
149−
150−instance (Monad m, Reflex t) => MonadDynamicWriter t w (DynamicWriterT t w m) where
151− tellDyn w = DynamicWriterT $ modify (Replaceable w never :)
152−
153−instance MonadReader r m => MonadReader r (DynamicWriterT t w m) where
154− ask = lift ask
155− local f (DynamicWriterT a) = DynamicWriterT $ mapStateT (local f) a
156− reader = lift . reader
157−
158−liftDynamicWriterTThroughSync :: Monad m' => (m (a, DynamicWriterAccumulator t w) -> m' (b, (a, DynamicWriterAccumulator t w))) -> DynamicWriterT t w m a -> DynamicWriterT t w m' (b, a)
159−liftDynamicWriterTThroughSync f (DynamicWriterT child) = DynamicWriterT $ do
160− s <- get
161− (b, (a, newS)) <- lift $ f $ runStateT child s
162− put newS
163− return (b, a)
164−
165−{-# INLINABLE liftDynamicWriterTElementConfig #-}
166−liftDynamicWriterTElementConfig :: ElementConfig er t (DynamicWriterT t w m) -> ElementConfig er t m
167−liftDynamicWriterTElementConfig cfg = cfg
168− { _elementConfig_eventSpec = _elementConfig_eventSpec cfg
169− }
170−
171−instance (DomBuilder t m, Monoid w, MonadHold t m, MonadFix m) => DomBuilder t (DynamicWriterT t w m) where
172− type DomBuilderSpace (DynamicWriterT t w m) = DomBuilderSpace m
173− textNode = liftTextNode
174− element elementTag cfg (DynamicWriterT child) = DynamicWriterT $ do
175− s <- get
176− let cfg' = liftDynamicWriterTElementConfig cfg
177− (el, (a, newS)) <- lift $ element elementTag cfg' $ runStateT child s
178− put newS
179− return (el, a)
180− placeholder cfg = do
181− let cfg' = cfg
182− { _placeholderConfig_insertAbove = runDynamicWriterTInternal <$> _placeholderConfig_insertAbove cfg
183− }
184− let manageChildren :: Event t (NonEmpty (Replaceable t (Dynamic t w))) -- ^ Add nodes on the right; these are in reverse order
185− -> Event t () -- ^ No more nodes will be added after this event fires
186− -> m (Replaceable t (Dynamic t w))
187− manageChildren newChildren additionsCeased = do
188− rec nextId <- hold (0 :: Int) newNextId -- We assume this will never wrap around
189− let numberedNewChildren :: Event t (Int, PatchMap (Map Int (Replaceable t (Dynamic t w))))
190− numberedNewChildren = flip pushAlways newChildren $ \rcs -> do
191− let cs = reverse $ toList rcs
192− myFirstId <- sample nextId
193− let (myNextId, numbered) = mapAccumL (\n v -> (succ n, (n, Just v))) myFirstId cs
194− return (myNextId, PatchMap $ Map.fromList numbered)
195− newNextId = fst <$> numberedNewChildren
196− mconcatIncrementalReplaceableDynMap Map.empty (snd <$> numberedNewChildren) additionsCeased
197− rec children <- lift $ manageChildren childOutputs $ cfg ^. deleteSelf
198− p <- DynamicWriterT $ do
199− modify (children:)
200− lift $ placeholder cfg'
201− let result = fst <$> _placeholder_insertedAbove p
202− childOutputs = fmapMaybe (nonEmpty . snd) $ _placeholder_insertedAbove p
203− return $ p
204− { _placeholder_insertedAbove = result
205− }
206− inputElement cfg = lift $ inputElement $ cfg & inputElementConfig_elementConfig %~ liftDynamicWriterTElementConfig
207− textAreaElement cfg = lift $ textAreaElement $ cfg & textAreaElementConfig_elementConfig %~ liftDynamicWriterTElementConfig
208− placeRawElement = lift . placeRawElement
209− wrapRawElement e cfg = lift $ wrapRawElement e $ cfg
210− { _rawElementConfig_eventSpec = _rawElementConfig_eventSpec cfg
211− }
212−
213−instance (Deletable t m, Reflex t, Monoid w, MonadHold t m, MonadFix m) => Deletable t (DynamicWriterT t w m) where
214− deletable delete child = do
215− (result, output) <- lift $ deletable delete $ runDynamicWriterT child
216− DynamicWriterT $ modify (Replaceable output (Nothing <$ delete) :)
217− return result
218−
219−instance PerformEvent t m => PerformEvent t (DynamicWriterT t w m) where
220− type Performable (DynamicWriterT t w m) = Performable m
221− performEvent_ = lift . performEvent_
222− performEvent = lift . performEvent
223−
224−instance TriggerEvent t m => TriggerEvent t (DynamicWriterT t w m) where
225− newTriggerEvent = lift newTriggerEvent
226− newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete
227− newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete
228−
229−instance PostBuild t m => PostBuild t (DynamicWriterT t w m) where
230− getPostBuild = lift getPostBuild
231−
232−instance MonadDynamicWriter t w m => MonadDynamicWriter t w (ReaderT r m) where
233− tellDyn = lift . tellDyn
234−
235−instance MonadState s m => MonadState s (DynamicWriterT t w m) where
236− get = lift get
237− put = lift . put
238−
239−instance HasJS x m => HasJS x (DynamicWriterT t w m) where
240− type JSM (DynamicWriterT t w m) = JSM m
241− liftJS = lift . liftJS
src/Reflex/Dom/Internal.hs+10−2
@@ -18,8 +18,8 @@ import Prelude hiding (concat, mapM, mapM_, sequence, sequence_)
1818import Reflex.Dom.Builder.Immediate
1919import Reflex.Dom.Class
2020import Reflex.Dom.Internal.Foreign
21−import Reflex.Dom.PerformEvent.Base
22−import Reflex.Dom.PostBuild.Class
21+import Reflex.PerformEvent.Base
22+import Reflex.PostBuild.Class
2323import Reflex.Host.Class
2424import Reflex.Spider (Global, Spider, SpiderHost, runSpiderHost)
2525
@@ -33,6 +33,7 @@ import Data.Dependent.Sum (DSum (..))
3333import Data.IORef
3434import Data.Maybe
3535import Data.Monoid ((<>))
36+import Data.Text (Text)
3637import qualified Data.Text as T
3738import Data.Text.Encoding
3839import GHCJS.DOM hiding (runWebGUI)
@@ -103,6 +104,13 @@ attachWidget' rootElement wv w = do
103104 _ <- appendChild rootElement $ Just df
104105 return (result, fc)
105106
107+-- | Run a reflex-dom application inside of an existing DOM element with the given ID
108+mainWidgetInElementById :: Text -> (forall x. Widget x ()) -> IO ()
109+mainWidgetInElementById eid w = runWebGUI $ \webView -> withWebViewSingleton webView $ \webViewSing -> do
110+ Just doc <- fmap DOM.castToHTMLDocument <$> webViewGetDomDocument webView
111+ Just root <- getElementById doc eid
112+ attachWidget root webViewSing w
113+
106114data AppInput t = AppInput
107115 { _appInput_window :: Window t
108116 }
src/Reflex/Dom/Old.hs+5−5
@@ -63,12 +63,12 @@ import GHCJS.DOM.NamedNodeMap as NNM
6363import GHCJS.DOM.Node (getFirstChild, getNodeName, getParentNode, getPreviousSibling, removeChild, toNode)
6464import GHCJS.DOM.Types (IsElement, IsNode)
6565import qualified GHCJS.DOM.Types as DOM
66−import Reflex
66+import Reflex.Class
6767import Reflex.Dom.Builder.Class
6868import Reflex.Dom.Builder.Immediate
6969import Reflex.Dom.Internal.Foreign
70−import Reflex.Dom.PerformEvent.Class
71−import Reflex.Dom.PostBuild.Class
70+import Reflex.PerformEvent.Class
71+import Reflex.PostBuild.Class
7272import Reflex.Dom.Widget.Basic
7373import Reflex.Host.Class
7474
@@ -133,7 +133,7 @@ instance Attributes m (Map Text Text) t where
133133
134134addStaticAttributes :: Applicative m => Map Text Text -> ElementConfig er t m -> m (ElementConfig er t m)
135135addStaticAttributes attrs cfg = do
136− let initialAttrs = Map.fromList $ first ((,) Nothing) <$> Map.toList attrs
136+ let initialAttrs = Map.fromList $ first (AttributeName Nothing) <$> Map.toList attrs
137137 pure $ cfg & elementConfig_initialAttributes .~ initialAttrs
138138
139139instance PostBuild t m => Attributes m (Dynamic t (Map Text Text)) t where
@@ -261,7 +261,7 @@ elStopPropagationNS ns elementTag en child = do
261261
262262elDynHtmlAttr' :: MonadWidget t m => Text -> Map Text Text -> Dynamic t Text -> m (Element EventResult GhcjsDomSpace t)
263263elDynHtmlAttr' elementTag attrs html = do
264− let cfg = def & initialAttributes .~ Map.mapKeys ((,) Nothing) attrs
264+ let cfg = def & initialAttributes .~ Map.mapKeys (AttributeName Nothing) attrs
265265 (e, _) <- element elementTag cfg $ return ()
266266 postBuild <- getPostBuild
267267 performEvent_ $ Element.setInnerHTML (_element_raw e) . Just <$> leftmost [updated html, tag (current html) postBuild]
src/Reflex/Dom/PerformEvent/Base.hsdeleted−177
@@ -1,177 +0,0 @@
1−{-# LANGUAGE FlexibleContexts #-}
2−{-# LANGUAGE FlexibleInstances #-}
3−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4−{-# LANGUAGE MultiParamTypeClasses #-}
5−{-# LANGUAGE RankNTypes #-}
6−{-# LANGUAGE RecursiveDo #-}
7−{-# LANGUAGE ScopedTypeVariables #-}
8−{-# LANGUAGE StandaloneDeriving #-}
9−{-# LANGUAGE TypeFamilies #-}
10−{-# LANGUAGE TypeOperators #-}
11−{-# LANGUAGE UndecidableInstances #-}
12−module Reflex.Dom.PerformEvent.Base where
13−
14−import Foreign.JavaScript.TH
15−import Reflex
16−import Reflex.Dom.Deletable.Class
17−import Reflex.Dom.PerformEvent.Class
18−import Reflex.Host.Class
19−
20−import Control.Lens
21−import Control.Monad.Exception
22−import Control.Monad.Identity
23−import Control.Monad.Ref
24−import Control.Monad.State.Strict
25−import Data.Align
26−import Data.Dependent.Map (DMap)
27−import qualified Data.Dependent.Map as DMap
28−import Data.Dependent.Sum
29−import Data.Functor.Compose
30−import Data.Functor.Misc
31−import Data.Maybe
32−import Data.Semigroup
33−import Data.These
34−import Data.Word
35−
36−newtype EventTriggerRef t m a = EventTriggerRef { unEventTriggerRef :: Ref m (Maybe (EventTrigger t a)) }
37−
38−newtype FireCommand t m = FireCommand { runFireCommand :: forall a. [DSum (EventTrigger t) Identity] -> ReadPhase m a -> m [a] } --TODO: The handling of this ReadPhase seems wrong, or at least inelegant; how do we actually make the decision about what order frames run in?
39−
40−newtype PerformEventT t m a = PerformEventT { unPerformEventT :: StateT [Event t (These (PerformEventT t m [DSum (EventTriggerRef t m) Identity]) ())] (HostFrame t) a }
41−
42−deriving instance ReflexHost t => Functor (PerformEventT t m)
43−deriving instance ReflexHost t => Applicative (PerformEventT t m)
44−deriving instance ReflexHost t => Monad (PerformEventT t m)
45−deriving instance ReflexHost t => MonadFix (PerformEventT t m)
46−deriving instance (ReflexHost t, MonadIO (HostFrame t)) => MonadIO (PerformEventT t m)
47−deriving instance (ReflexHost t, MonadException (HostFrame t)) => MonadException (PerformEventT t m)
48−
49−instance (ReflexHost t, MonadAsyncException (HostFrame t)) => MonadAsyncException (PerformEventT t m) where
50− mask f = PerformEventT $ mask $ \unmask -> unPerformEventT $ f $ PerformEventT . unmask . unPerformEventT
51−
52−instance (ReflexHost t, HasWebView (HostFrame t)) => HasWebView (PerformEventT t m) where
53− type WebViewPhantom (PerformEventT t m) = WebViewPhantom (HostFrame t)
54− askWebView = PerformEventT $ lift askWebView
55−
56−instance (ReflexHost t, Ref m ~ Ref IO, MonadRef (HostFrame t), Ref (HostFrame t) ~ Ref IO) => PerformEvent t (PerformEventT t m) where
57− type Performable (PerformEventT t m) = PerformEventT t m
58− {-# INLINABLE performEvent_ #-}
59− performEvent_ = PerformEventT . modify . (:) . fmap (This . (>> return []))
60− {-# INLINABLE performEvent #-}
61− performEvent e = PerformEventT $ do
62− (eResult, reResultTrigger) <- newEventWithTriggerRef
63− modify $ (:) $ ffor e $ \o -> This $ do
64− result <- o
65− return [EventTriggerRef reResultTrigger :=> Identity result]
66− return eResult
67−
68−instance (ReflexHost t, Monad (HostFrame t), Ref (HostFrame t) ~ Ref IO, Ref m ~ Ref IO) => Deletable t (PerformEventT t m) where
69− {-# INLINABLE deletable #-}
70− deletable d a = PerformEventT $ do
71− (result, reverseEventsToPerform) <- lift $ runStateT (unPerformEventT a) []
72− let (numberedEvents, _) = numberWith (\n e -> Const2 n :=> e) (reverse reverseEventsToPerform) (1 :: Word64)
73− eventToPerform <- lift $ mergePerformEventsAndAdd (DMap.fromList numberedEvents) never
74− modify (align eventToPerform d :)
75− return result
76−
77−instance ReflexHost t => MonadReflexCreateTrigger t (PerformEventT t m) where
78− {-# INLINABLE newEventWithTrigger #-}
79− newEventWithTrigger = PerformEventT . lift . newEventWithTrigger
80− {-# INLINABLE newFanEventWithTrigger #-}
81− newFanEventWithTrigger f = PerformEventT $ lift $ newFanEventWithTrigger f
82−
83−{-# INLINABLE numberWith #-}
84−numberWith :: (Enum n, Traversable t) => (n -> a -> b) -> t a -> n -> (t b, n)
85−numberWith f t n0 = flip runState n0 $ forM t $ \x -> state $ \n -> (f n x, succ n)
86−
87−{-# INLINABLE mergePerformEventsAndAdd #-}
88−mergePerformEventsAndAdd :: forall t m. ReflexHost t
89− => DMap (Const2 Word64 (These (PerformEventT t m [DSum (EventTriggerRef t m) Identity]) ())) (Event t)
90− -> Event t (PatchDMap (DMap (Const2 Word64 (These (PerformEventT t m [DSum (EventTriggerRef t m) Identity]) ())) (Event t)))
91− -> HostFrame t (Event t (PerformEventT t m [DSum (EventTriggerRef t m) Identity]))
92−mergePerformEventsAndAdd initial eAddNew = do
93− rec events :: Incremental t PatchDMap (DMap (Const2 Word64 (These (PerformEventT t m [DSum (EventTriggerRef t m) Identity]) ())) (Event t))
94− <- holdIncremental initial $ eAddNew <> eDelete --TODO: Eliminate empty firings
95− let event = mergeWith DMap.union [mergeIncremental events, coincidence (fmap (\(PatchDMap m) -> merge $ DMap.mapMaybeWithKey (const getCompose) m) eAddNew)]
96− eventToPerform :: Event t (PerformEventT t m [DSum (EventTriggerRef t m) Identity])
97− eventToPerform = ffor event $
98− fmap concat .
99− sequence .
100− fmapMaybe (\(Const2 _ :=> Identity x) -> x ^? here) .
101− DMap.toList
102− eDelete :: Event t (PatchDMap (DMap (Const2 Word64 (These (PerformEventT t m [DSum (EventTriggerRef t m) Identity]) ())) (Event t)))
103− eDelete = fforMaybe event $
104− fmap (PatchDMap . DMap.fromList) .
105− (\l -> if null l then Nothing else Just l) .
106− fmapMaybe (\(Const2 k :=> Identity x) -> (Const2 k :=> Compose Nothing) <$ x ^? there) .
107− DMap.toList
108− return eventToPerform
109−
110−{-# INLINABLE runPerformEventT #-}
111−runPerformEventT :: forall t m a. (ReflexHost t, MonadRef (HostFrame t), Ref (HostFrame t) ~ Ref IO, Ref m ~ Ref IO) => PerformEventT t m a -> HostFrame t (a, Event t (HostFrame t [DSum (EventTriggerRef t m) Identity]))
112−runPerformEventT (PerformEventT a) = do
113− (result, reverseEventsToPerform) <- runStateT a []
114− (eAddNew, reAddNewTrigger) <- newEventWithTriggerRef
115− let (numberedEvents, nextNumber) = numberWith (\n e -> Const2 n :=> e) (reverse reverseEventsToPerform) (1 :: Word64)
116− nextNumberRef <- newRef nextNumber
117− let runResult :: PerformEventT t m [DSum (EventTriggerRef t m) Identity] -> HostFrame t [DSum (EventTriggerRef t m) Identity]
118− runResult (PerformEventT r) = do
119− (followups, reverseNewEventsToPerform) <- runStateT r []
120− oldN <- readRef nextNumberRef
121− let (numberedNewEvents, newN) = numberWith (\n e -> Const2 n :=> Compose (Just e)) (reverse reverseNewEventsToPerform) oldN
122− if newN == oldN then return followups else do
123− writeRef nextNumberRef newN
124− return $ (EventTriggerRef reAddNewTrigger :=> Identity (PatchDMap (DMap.fromList numberedNewEvents))) : followups
125− eventToPerform <- mergePerformEventsAndAdd (DMap.fromList numberedEvents) eAddNew
126− return (result, runResult <$> eventToPerform)
127−
128−{-# INLINABLE hostPerformEventT #-}
129−hostPerformEventT :: forall t m a. (Monad m, MonadSubscribeEvent t m, MonadReflexHost t m, MonadRef m, Ref m ~ Ref IO, MonadRef (HostFrame t), Ref (HostFrame t) ~ Ref IO) => PerformEventT t m a -> m (a, FireCommand t m)
130−hostPerformEventT a = do
131− (result, eventToPerform) <- runHostFrame $ runPerformEventT a
132− eventToPerformHandle <- subscribeEvent eventToPerform
133− return $ (,) result $ FireCommand $ \triggers (readPhase :: ReadPhase m a') -> do
134− let go :: [DSum (EventTrigger t) Identity] -> m [a']
135− go ts = do
136− (result', mToPerform) <- fireEventsAndRead ts $ do
137− mToPerform <- sequence =<< readEvent eventToPerformHandle
138− result' <- readPhase
139− return (result', mToPerform)
140− case mToPerform of
141− Nothing -> return [result']
142− Just toPerform -> do
143− followupEventTriggerRefs <- runHostFrame toPerform
144− followupEventTriggers <- forM followupEventTriggerRefs $ \(EventTriggerRef rt :=> x) -> do
145− mt <- readRef rt
146− return $ fmap (:=> x) mt
147− fmap (result':) $ go $ catMaybes followupEventTriggers
148− go triggers
149−
150−instance ReflexHost t => MonadSample t (PerformEventT t m) where
151− {-# INLINABLE sample #-}
152− sample = PerformEventT . lift . sample
153−
154−instance (ReflexHost t, MonadHold t m) => MonadHold t (PerformEventT t m) where
155− {-# INLINABLE hold #-}
156− hold v0 v' = PerformEventT $ lift $ hold v0 v'
157− {-# INLINABLE holdDyn #-}
158− holdDyn v0 v' = PerformEventT $ lift $ holdDyn v0 v'
159− {-# INLINABLE holdIncremental #-}
160− holdIncremental v0 v' = PerformEventT $ lift $ holdIncremental v0 v'
161−
162−instance (MonadRef (HostFrame t), ReflexHost t) => MonadRef (PerformEventT t m) where
163− type Ref (PerformEventT t m) = Ref (HostFrame t)
164− {-# INLINABLE newRef #-}
165− newRef = PerformEventT . lift . newRef
166− {-# INLINABLE readRef #-}
167− readRef = PerformEventT . lift . readRef
168− {-# INLINABLE writeRef #-}
169− writeRef r = PerformEventT . lift . writeRef r
170−
171−instance (MonadAtomicRef (HostFrame t), ReflexHost t) => MonadAtomicRef (PerformEventT t m) where
172− {-# INLINABLE atomicModifyRef #-}
173− atomicModifyRef r = PerformEventT . lift . atomicModifyRef r
174−
175−instance (HasJS x (HostFrame t), ReflexHost t) => HasJS x (PerformEventT t m) where
176− type JSM (PerformEventT t m) = JSM (HostFrame t)
177− liftJS = PerformEventT . lift . liftJS
src/Reflex/Dom/PerformEvent/Class.hsdeleted−46
@@ -1,46 +0,0 @@
1−{-# LANGUAGE FlexibleContexts #-}
2−{-# LANGUAGE FlexibleInstances #-}
3−{-# LANGUAGE FunctionalDependencies #-}
4−{-# LANGUAGE MultiParamTypeClasses #-}
5−{-# LANGUAGE RankNTypes #-}
6−{-# LANGUAGE ScopedTypeVariables #-}
7−{-# LANGUAGE TypeFamilies #-}
8−{-# LANGUAGE TypeOperators #-}
9−{-# LANGUAGE UndecidableInstances #-}
10−module Reflex.Dom.PerformEvent.Class where
11−
12−import Reflex
13−
14−import Control.Monad.Reader
15−
16−class (Reflex t, Monad (Performable m), Monad m) => PerformEvent t m | m -> t where
17− type Performable m :: * -> *
18− performEvent :: Event t (Performable m a) -> m (Event t a)
19− performEvent_ :: Event t (Performable m ()) -> m ()
20−
21−--TODO: Shouldn't have IO hard-coded
22−class Monad m => TriggerEvent t m | m -> t where
23− newTriggerEvent :: m (Event t a, a -> IO ())
24− newTriggerEventWithOnComplete :: m (Event t a, a -> IO () -> IO ()) --TODO: This and newTriggerEvent should be unified somehow
25− newEventWithLazyTriggerWithOnComplete :: ((a -> IO () -> IO ()) -> IO (IO ())) -> m (Event t a)
26−
27−{-# INLINABLE performEventAsync #-}
28−performEventAsync :: (TriggerEvent t m, PerformEvent t m) => Event t ((a -> IO ()) -> Performable m ()) -> m (Event t a)
29−performEventAsync e = do
30− (eOut, triggerEOut) <- newTriggerEvent
31− performEvent_ $ fmap ($ triggerEOut) e
32− return eOut
33−
34−instance PerformEvent t m => PerformEvent t (ReaderT r m) where
35− type Performable (ReaderT r m) = ReaderT r (Performable m)
36− performEvent_ e = do
37− r <- ask
38− lift $ performEvent_ $ flip runReaderT r <$> e
39− performEvent e = do
40− r <- ask
41− lift $ performEvent $ flip runReaderT r <$> e
42−
43−instance TriggerEvent t m => TriggerEvent t (ReaderT r m) where
44− newTriggerEvent = lift newTriggerEvent
45− newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete
46− newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete
src/Reflex/Dom/PostBuild/Class.hsdeleted−128
@@ -1,128 +0,0 @@
1−{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE FlexibleInstances #-}
3−{-# LANGUAGE FunctionalDependencies #-}
4−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5−{-# LANGUAGE MultiParamTypeClasses #-}
6−{-# LANGUAGE RecursiveDo #-}
7−{-# LANGUAGE ScopedTypeVariables #-}
8−{-# LANGUAGE TypeFamilies #-}
9−{-# LANGUAGE TypeOperators #-}
10−{-# LANGUAGE UndecidableInstances #-}
11−module Reflex.Dom.PostBuild.Class where
12−
13−import Control.Lens hiding (element)
14−import Control.Monad.Exception
15−import Control.Monad.Reader
16−import Control.Monad.Ref
17−import Control.Monad.Trans.Control
18−import Foreign.JavaScript.TH
19−import Reflex
20−import Reflex.Dom.Builder.Class
21−import Reflex.Dom.PerformEvent.Class
22−import Reflex.Host.Class
23−
24−class (Reflex t, Monad m) => PostBuild t m | m -> t where
25− getPostBuild :: m (Event t ())
26−
27−newtype PostBuildT t m a = PostBuildT { unPostBuildT :: ReaderT (Event t ()) m a } deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadTrans, MonadException, MonadAsyncException)
28−
29−instance MonadTransControl (PostBuildT t) where
30− type StT (PostBuildT t) a = StT (ReaderT (Event t ())) a
31− {-# INLINABLE liftWith #-}
32− liftWith = defaultLiftWith PostBuildT unPostBuildT
33− {-# INLINABLE restoreT #-}
34− restoreT = defaultRestoreT PostBuildT
35−
36−instance (Reflex t, Monad m) => PostBuild t (PostBuildT t m) where
37− {-# INLINABLE getPostBuild #-}
38− getPostBuild = PostBuildT ask
39−
40−instance Deletable t m => Deletable t (PostBuildT t m) where
41− {-# INLINABLE deletable #-}
42− deletable = liftThrough . deletable
43−
44−{-# INLINABLE liftPostBuildTElementConfig #-}
45−liftPostBuildTElementConfig :: ElementConfig er t (PostBuildT t m) -> ElementConfig er t m
46−liftPostBuildTElementConfig cfg = cfg
47− { _elementConfig_eventSpec = _elementConfig_eventSpec cfg
48− }
49−
50−instance (DomBuilder t m, PerformEvent t m, MonadFix m, MonadHold t m) => DomBuilder t (PostBuildT t m) where
51− type DomBuilderSpace (PostBuildT t m) = DomBuilderSpace m
52− {-# INLINABLE textNode #-}
53− textNode = lift . textNode
54− {-# INLINABLE element #-}
55− element t cfg child = liftWith $ \run -> element t (liftPostBuildTElementConfig cfg) $ run child
56− {-# INLINABLE placeholder #-}
57− placeholder cfg = lift $ do
58− rec childPostBuild <- deletable (_placeholder_deletedSelf p) $ performEvent $ return () <$ _placeholder_insertedAbove p
59− p <- placeholder $ cfg
60− { _placeholderConfig_insertAbove = ffor (_placeholderConfig_insertAbove cfg) $ \a -> runPostBuildT a =<< headE childPostBuild
61− }
62− return p
63− {-# INLINABLE inputElement #-}
64− inputElement cfg = lift $ inputElement $ cfg & inputElementConfig_elementConfig %~ liftPostBuildTElementConfig
65− {-# INLINABLE textAreaElement #-}
66− textAreaElement cfg = lift $ textAreaElement $ cfg & textAreaElementConfig_elementConfig %~ liftPostBuildTElementConfig
67− placeRawElement = lift . placeRawElement
68− wrapRawElement e cfg = liftWith $ \run -> wrapRawElement e $ fmap1 run cfg
69−
70−instance MonadSample t m => MonadSample t (PostBuildT t m) where
71− {-# INLINABLE sample #-}
72− sample = lift . sample
73−
74−instance MonadHold t m => MonadHold t (PostBuildT t m) where
75− {-# INLINABLE hold #-}
76− hold v0 = lift . hold v0
77− {-# INLINABLE holdDyn #-}
78− holdDyn v0 = lift . holdDyn v0
79− {-# INLINABLE holdIncremental #-}
80− holdIncremental v0 = lift . holdIncremental v0
81−
82−instance PerformEvent t m => PerformEvent t (PostBuildT t m) where
83− type Performable (PostBuildT t m) = PostBuildT t (Performable m)
84− {-# INLINABLE performEvent_ #-}
85− performEvent_ e = liftWith $ \run -> performEvent_ $ fmap run e
86− {-# INLINABLE performEvent #-}
87− performEvent e = liftWith $ \run -> performEvent $ fmap run e
88−
89−instance (ReflexHost t, MonadReflexCreateTrigger t m) => MonadReflexCreateTrigger t (PostBuildT t m) where
90− {-# INLINABLE newEventWithTrigger #-}
91− newEventWithTrigger = PostBuildT . lift . newEventWithTrigger
92− {-# INLINABLE newFanEventWithTrigger #-}
93− newFanEventWithTrigger f = PostBuildT $ lift $ newFanEventWithTrigger f
94−
95−instance TriggerEvent t m => TriggerEvent t (PostBuildT t m) where
96− {-# INLINABLE newTriggerEvent #-}
97− newTriggerEvent = lift newTriggerEvent
98− {-# INLINABLE newTriggerEventWithOnComplete #-}
99− newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete
100− newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete
101−
102−instance MonadRef m => MonadRef (PostBuildT t m) where
103− type Ref (PostBuildT t m) = Ref m
104− {-# INLINABLE newRef #-}
105− newRef = lift . newRef
106− {-# INLINABLE readRef #-}
107− readRef = lift . readRef
108− {-# INLINABLE writeRef #-}
109− writeRef r = lift . writeRef r
110−
111−instance MonadAtomicRef m => MonadAtomicRef (PostBuildT t m) where
112− {-# INLINABLE atomicModifyRef #-}
113− atomicModifyRef r = lift . atomicModifyRef r
114−
115−instance (HasJS x m, ReflexHost t) => HasJS x (PostBuildT t m) where
116− type JSM (PostBuildT t m) = JSM m
117− liftJS = lift . liftJS
118−
119−instance HasWebView m => HasWebView (PostBuildT t m) where
120− type WebViewPhantom (PostBuildT t m) = WebViewPhantom m
121− askWebView = lift askWebView
122−
123−{-# INLINABLE runPostBuildT #-}
124−runPostBuildT :: PostBuildT t m a -> Event t () -> m a
125−runPostBuildT (PostBuildT a) = runReaderT a
126−
127−instance PostBuild t m => PostBuild t (ReaderT r m) where
128− getPostBuild = lift getPostBuild
src/Reflex/Dom/Time.hs+4−3
@@ -6,9 +6,10 @@
66{-# LANGUAGE TypeFamilies #-}
77module Reflex.Dom.Time where
88
9−import Reflex
10−import Reflex.Dom.PerformEvent.Class
11−import Reflex.Dom.PostBuild.Class
9+import Reflex.Class
10+import Reflex.Dynamic
11+import Reflex.PerformEvent.Class
12+import Reflex.PostBuild.Class
1213
1314import Control.Concurrent
1415import qualified Control.Concurrent.Thread.Delay as Concurrent
src/Reflex/Dom/WebSocket.hs+13−7
@@ -23,10 +23,10 @@ module Reflex.Dom.WebSocket where
2323
2424import Prelude hiding (all, concat, concatMap, div, mapM, mapM_, sequence, span)
2525
26−import Reflex
26+import Reflex.Class
2727import Reflex.Dom.Class
28−import Reflex.Dom.PerformEvent.Class
29−import Reflex.Dom.PostBuild.Class
28+import Reflex.PerformEvent.Class
29+import Reflex.PostBuild.Class
3030import Reflex.Dom.WebSocket.Foreign
3131
3232import Control.Concurrent
@@ -42,11 +42,11 @@ import Data.IORef
4242import Data.Maybe (isJust)
4343import Data.Text
4444
45−data WebSocketConfig t
46− = WebSocketConfig { _webSocketConfig_send :: Event t [ByteString]
45+data WebSocketConfig t a
46+ = WebSocketConfig { _webSocketConfig_send :: Event t [a]
4747 }
4848
49−instance Reflex t => Default (WebSocketConfig t) where
49+instance Reflex t => Default (WebSocketConfig t a) where
5050 def = WebSocketConfig never
5151
5252data WebSocket t
@@ -54,7 +54,13 @@ data WebSocket t
5454 , _webSocket_open :: Event t ()
5555 }
5656
57−webSocket :: (MonadIO m, MonadIO (Performable m), HasWebView m, PerformEvent t m, TriggerEvent t m, PostBuild t m) => Text -> WebSocketConfig t -> m (WebSocket t)
57+-- This can be used to send either binary or text messages for the same websocket connection
58+instance (IsWebSocketMessage a, IsWebSocketMessage b) => IsWebSocketMessage (Either a b) where
59+ webSocketSend jws (Left a) = webSocketSend jws a
60+ webSocketSend jws (Right a) = webSocketSend jws a
61+
62+
63+webSocket :: (MonadIO m, MonadIO (Performable m), HasWebView m, PerformEvent t m, TriggerEvent t m, PostBuild t m, IsWebSocketMessage a) => Text -> WebSocketConfig t a -> m (WebSocket t)
5864webSocket url config = do
5965 wv <- fmap unWebViewSingleton askWebView
6066 (eRecv, onMessage) <- newTriggerEvent
src/Reflex/Dom/Widget/Basic.hs+5−30
@@ -12,10 +12,12 @@
1212{-# LANGUAGE TypeFamilies #-}
1313module Reflex.Dom.Widget.Basic where
1414
15+import Reflex.Class as Reflex
1516import Reflex.Dom.Builder.Class
1617import Reflex.Dom.Class
1718import Reflex.Dom.Internal.Foreign ()
18−import Reflex.Dom.PostBuild.Class
19+import Reflex.Dynamic
20+import Reflex.PostBuild.Class
1921
2022import Control.Arrow
2123import Control.Lens hiding (children, element)
@@ -36,7 +38,6 @@ import qualified Data.Text as T
3638import Data.These
3739import Data.Traversable
3840import Prelude hiding (mapM, mapM_, sequence, sequence_)
39−import Reflex
4041
4142widgetHoldInternal :: DomBuilder t m => m a -> Event t (m b) -> m (a, Event t b)
4243widgetHoldInternal child0 child' = do
@@ -214,32 +215,6 @@ selectViewListWithKey_ :: forall t m k v a. (DomBuilder t m, Ord k, PostBuild t
214215 -> m (Event t k) -- ^ Event that fires when any child's return Event fires. Contains key of an arbitrary firing widget.
215216selectViewListWithKey_ selection vals mkChild = fmap fst <$> selectViewListWithKey selection vals mkChild
216217
217−{-
218−{-# INLINABLE elWith #-}
219−elWith :: (DomBuilder t m, Attributes m attrs) => Text -> ElConfig attrs -> m a -> m a
220−elWith elementTag cfg child = do
221− (_, result) <- buildElementNS (cfg ^. namespace) elementTag (cfg ^. attributes) child
222− return result
223−
224−{-# INLINABLE elWith' #-}
225−elWith' :: (DomBuilder t m, Attributes m attrs) => Text -> ElConfig attrs -> m a -> m (El t, a)
226−elWith' elementTag cfg child = do
227− (e, result) <- buildElementNS (cfg ^. namespace) elementTag (cfg ^. attributes) child
228− e' <- wrapElement defaultDomEventHandler e
229− return (e', result)
230−
231−{-# INLINABLE emptyElWith #-}
232−emptyElWith :: (DomBuilder t m, Attributes m attrs) => Text -> ElConfig attrs -> m ()
233−emptyElWith elementTag cfg = do
234− _ <- buildEmptyElementNS (cfg ^. namespace) elementTag (cfg ^. attributes)
235− return ()
236−
237−{-# INLINABLE emptyElWith' #-}
238−emptyElWith' :: (DomBuilder t m, Attributes m attrs) => Text -> ElConfig attrs -> m (El t)
239−emptyElWith' elementTag cfg = do
240− wrapElement defaultDomEventHandler =<< buildEmptyElementNS (cfg ^. namespace) elementTag (cfg ^. attributes)
241−-}
242−
243218{-# INLINABLE el #-}
244219el :: forall t m a. DomBuilder t m => Text -> m a -> m a
245220el elementTag child = snd <$> el' elementTag child
@@ -267,7 +242,7 @@ el' elementTag = element elementTag def
267242{-# INLINABLE elAttr' #-}
268243elAttr' :: forall t m a. DomBuilder t m => Text -> Map Text Text -> m a -> m (Element EventResult (DomBuilderSpace m) t, a)
269244elAttr' elementTag attrs = element elementTag $ def
270− & initialAttributes .~ Map.mapKeys (\k -> (Nothing, k)) attrs
245+ & initialAttributes .~ Map.mapKeys (AttributeName Nothing) attrs
271246
272247{-# INLINABLE elClass' #-}
273248elClass' :: forall t m a. DomBuilder t m => Text -> Text -> m a -> m (Element EventResult (DomBuilderSpace m) t, a)
@@ -299,7 +274,7 @@ dynamicAttributesToModifyAttributes d = do
299274 That new -> do
300275 old <- sample $ current d
301276 return $ diffMap old new
302− return $ Map.fromList . fmap (\(k, v) -> ((Nothing, k), v)) . Map.toList <$> modificationsNeeded
277+ return $ Map.fromList . fmap (first (AttributeName Nothing)) . Map.toList <$> modificationsNeeded
303278
304279--------------------------------------------------------------------------------
305280-- Copied and pasted from Reflex.Widget.Class
src/Reflex/Dom/Widget/Input.hs+42−38
@@ -34,17 +34,16 @@ import GHCJS.DOM.Element (castToElement)
3434import qualified GHCJS.DOM.Element as Element
3535import GHCJS.DOM.EventM (on)
3636import qualified GHCJS.DOM.FileList as FileList
37−import GHCJS.DOM.HTMLInputElement (HTMLInputElement, castToHTMLInputElement)
38−import GHCJS.DOM.HTMLSelectElement (castToHTMLSelectElement)
39−import qualified GHCJS.DOM.HTMLSelectElement as HTMLSelectElement
40−import GHCJS.DOM.HTMLTextAreaElement (HTMLTextAreaElement, castToHTMLTextAreaElement)
37+import GHCJS.DOM.HTMLInputElement (HTMLInputElement)
38+import GHCJS.DOM.HTMLTextAreaElement (HTMLTextAreaElement)
4139import GHCJS.DOM.Types (File)
42−import Reflex
40+import Reflex.Class
41+import Reflex.Dynamic
4342import Reflex.Dom.Builder.Class
4443import Reflex.Dom.Builder.Immediate
4544import Reflex.Dom.Class
46−import Reflex.Dom.PerformEvent.Class
47−import Reflex.Dom.PostBuild.Class
45+import Reflex.PerformEvent.Class
46+import Reflex.PostBuild.Class
4847import Reflex.Dom.Widget.Basic
4948import qualified Text.Read as T
5049
@@ -58,9 +57,16 @@ data TextInput t
5857 , _textInput_keydown :: Event t Int
5958 , _textInput_keyup :: Event t Int
6059 , _textInput_hasFocus :: Dynamic t Bool
61− , _textInput_element :: HTMLInputElement
60+ , _textInput_builderElement :: InputElement EventResult GhcjsDomSpace t
6261 }
6362
63+_textInput_element :: TextInput t -> HTMLInputElement
64+_textInput_element = _inputElement_raw . _textInput_builderElement
65+
66+instance Reflex t => HasDomEvent t (TextInput t) en where
67+ type DomEventType (TextInput t) en = DomEventType (InputElement EventResult GhcjsDomSpace t) en
68+ domEvent en = domEvent en . _textInput_builderElement
69+
6470data TextInputConfig t
6571 = TextInputConfig { _textInputConfig_inputType :: Text
6672 , _textInputConfig_initialValue :: Text
@@ -92,12 +98,17 @@ textInput (TextInputConfig inputType initial eSetValue dAttrs) = do
9298 , _textInput_keydown = domEvent Keydown i
9399 , _textInput_keyup = domEvent Keyup i
94100 , _textInput_hasFocus = _inputElement_hasFocus i
95− , _textInput_element = castToHTMLInputElement $ _element_raw $ _inputElement_element i
101+ , _textInput_builderElement = i
96102 }
97103
98−{-# INLINABLE textInputGetEnter #-}
104+{-# INLINE textInputGetEnter #-}
105+{-# DEPRECATED textInputGetEnter "Use 'keypress Enter' instead" #-}
99106textInputGetEnter :: Reflex t => TextInput t -> Event t ()
100−textInputGetEnter i = fmapMaybe (\n -> if keyCodeLookup n == Enter then Just () else Nothing) $ _textInput_keypress i
107+textInputGetEnter = keypress Enter
108+
109+{-# INLINABLE keypress #-}
110+keypress :: (Reflex t, HasDomEvent t e 'KeypressTag, DomEventType e 'KeypressTag ~ Int) => Key -> e -> Event t ()
111+keypress key i = fmapMaybe (\n -> if keyCodeLookup n == key then Just () else Nothing) $ domEvent Keypress i
101112
102113data RangeInputConfig t
103114 = RangeInputConfig { _rangeInputConfig_initialValue :: Float
@@ -135,7 +146,7 @@ rangeInput (RangeInputConfig initial eSetValue dAttrs) = do
135146 , _rangeInput_input = read . T.unpack <$> _inputElement_input i
136147 , _rangeInput_mouseup = domEvent Mouseup i
137148 , _rangeInput_hasFocus = _inputElement_hasFocus i
138− , _rangeInput_element = castToHTMLInputElement $ _element_raw $ _inputElement_element i
149+ , _rangeInput_element = _inputElement_raw i
139150 }
140151
141152data TextAreaConfig t
@@ -172,7 +183,7 @@ textArea (TextAreaConfig initial eSet attrs) = do
172183 , _textArea_input = _textAreaElement_input i
173184 , _textArea_keypress = domEvent Keypress i
174185 , _textArea_hasFocus = _textAreaElement_hasFocus i
175− , _textArea_element = castToHTMLTextAreaElement $ _element_raw $ _textAreaElement_element i
186+ , _textArea_element = _textAreaElement_raw i
176187 }
177188
178189data CheckboxConfig t
@@ -202,7 +213,7 @@ checkbox checked config = do
202213 i <- inputElement $ def
203214 & inputElementConfig_initialChecked .~ checked
204215 & inputElementConfig_setChecked .~ _checkboxConfig_setValue config
205− & inputElementConfig_elementConfig . elementConfig_initialAttributes .~ Map.mapKeys ((,) Nothing) permanentAttrs
216+ & inputElementConfig_elementConfig . elementConfig_initialAttributes .~ Map.mapKeys (AttributeName Nothing) permanentAttrs
206217 & inputElementConfig_elementConfig . elementConfig_modifyAttributes .~ modifyAttrs
207218 return $ Checkbox
208219 { _checkbox_value = _inputElement_checked i
@@ -279,7 +290,7 @@ checkboxView dAttrs dValue = do
279290 elementConfig :: ElementConfig CheckboxViewEventResult t m
280291 elementConfig = (def :: ElementConfig EventResult t m)
281292 { _elementConfig_modifyAttributes = modifyAttrs
282− , _elementConfig_initialAttributes = Map.mapKeys ((,) Nothing) permanentAttrs
293+ , _elementConfig_initialAttributes = Map.mapKeys (AttributeName Nothing) permanentAttrs
283294 , _elementConfig_eventSpec = GhcjsEventSpec
284295 { _ghcjsEventSpec_filters = filters
285296 , _ghcjsEventSpec_handler = \(en, GhcjsDomEvent evt) -> case en of
@@ -407,7 +418,7 @@ regularToDropdownViewEventType en r = case en of
407418--TODO: We should allow the user to specify an ordering instead of relying on the ordering of the Map
408419-- | Create a dropdown box
409420-- The first argument gives the initial value of the dropdown; if it is not present in the map of options provided, it will be added with an empty string as its text
410−dropdown :: forall k t m. (DomBuilder t m, MonadFix m, MonadHold t m, PerformEvent t m, MonadIO (Performable m), MonadIO m, TriggerEvent t m, PostBuild t m, DomBuilderSpace m ~ GhcjsDomSpace, Ord k) => k -> Dynamic t (Map k Text) -> DropdownConfig t k -> m (Dropdown t k)
421+dropdown :: forall k t m. (DomBuilder t m, MonadFix m, MonadHold t m, PostBuild t m, Ord k) => k -> Dynamic t (Map k Text) -> DropdownConfig t k -> m (Dropdown t k)
411422dropdown k0 options (DropdownConfig setK attrs) = do
412423 optionsWithAddedKeys <- fmap (zipDynWith Map.union options) $ foldDyn Map.union (k0 =: "") $ fmap (=: "") setK
413424 defaultKey <- holdDyn k0 setK
@@ -415,31 +426,16 @@ dropdown k0 options (DropdownConfig setK attrs) = do
415426 let xs = fmap (\(ix, (k, v)) -> ((ix, k), ((ix, k), v))) $ zip [0::Int ..] $ Map.toList os
416427 in (Map.fromList $ map snd xs, Bimap.fromList $ map fst xs)
417428 modifyAttrs <- dynamicAttributesToModifyAttributes attrs
418− let cfg = (def :: ElementConfig EventResult t m)
419− { _elementConfig_modifyAttributes = modifyAttrs
420− , _elementConfig_eventSpec = GhcjsEventSpec
421− { _ghcjsEventSpec_filters = DMap.singleton Change $ GhcjsEventFilter $ \(GhcjsDomEvent evt) -> do
422− Just t <- Event.getTarget evt
423− Just v <- HTMLSelectElement.getValue $ HTMLSelectElement.castToHTMLSelectElement t
424− return $ (,) mempty $ return $ Just $ DropdownViewEventResult v
425− , _ghcjsEventSpec_handler = \(en, GhcjsDomEvent evt) -> case en of
426− Click -> error "impossible"
427− _ -> do
428− Just e <- withIsEvent en $ Event.getTarget evt
429− mr <- runReaderT (defaultDomEventHandler (castToElement e) en) evt
430− return $ ffor mr $ \(EventResult r) -> DropdownViewEventResult $ regularToDropdownViewEventType en r
431− }
432− }
433− (eRaw, _) <- element "select" cfg $ listWithKey indexedOptions $ \(ix, k) v -> do
429+ let cfg = def
430+ & selectElementConfig_elementConfig . elementConfig_modifyAttributes .~ modifyAttrs
431+ & selectElementConfig_setValue .~ fmap (T.pack . show) (attachPromptlyDynWithMaybe (flip Bimap.lookupR) ixKeys setK)
432+ (eRaw, _) <- selectElement cfg $ listWithKey indexedOptions $ \(ix, k) v -> do
434433 let optionAttrs = fmap (\dk -> "value" =: T.pack (show ix) <> if dk == k then "selected" =: "selected" else mempty) defaultKey
435434 elDynAttr "option" optionAttrs $ dynText v
436− let e = castToHTMLSelectElement $ _element_raw eRaw
437− performEvent_ $ HTMLSelectElement.setValue e . Just . show <$> attachPromptlyDynWithMaybe (flip Bimap.lookupR) ixKeys setK
438− let lookupSelected ks value = do
439− v <- value
440− key <- T.readMaybe v
435+ let lookupSelected ks v = do
436+ key <- T.readMaybe $ T.unpack v
441437 Bimap.lookup key ks
442− eChange <- attachPromptlyDynWith lookupSelected ixKeys <$> wrapDomEvent e (`on` Element.change) (HTMLSelectElement.getValue e)
438+ let eChange = attachPromptlyDynWith lookupSelected ixKeys $ _selectElement_change eRaw
443439 let readKey keys mk = fromMaybe k0 $ do
444440 k <- mk
445441 guard $ Bimap.memberR k keys
@@ -514,6 +510,14 @@ class HasValue a where
514510 type Value a :: *
515511 value :: a -> Value a
516512
513+instance HasValue (InputElement er d t) where
514+ type Value (InputElement er d t) = Dynamic t Text
515+ value = _inputElement_value
516+
517+instance HasValue (TextAreaElement er d t) where
518+ type Value (TextAreaElement er d t) = Dynamic t Text
519+ value = _textAreaElement_value
520+
517521instance HasValue (TextArea t) where
518522 type Value (TextArea t) = Dynamic t Text
519523 value = _textArea_value
src/Reflex/Dom/Widget/Lazy.hs+4−3
@@ -6,13 +6,14 @@
66{-# LANGUAGE TypeFamilies #-}
77module Reflex.Dom.Widget.Lazy where
88
9−import Reflex
9+import Reflex.Class
1010import Reflex.Dom.Builder.Class
1111import Reflex.Dom.Builder.Immediate
1212import Reflex.Dom.Class
13−import Reflex.Dom.PerformEvent.Class
14−import Reflex.Dom.PostBuild.Class
1513import Reflex.Dom.Widget.Basic
14+import Reflex.Dynamic
15+import Reflex.PerformEvent.Class
16+import Reflex.PostBuild.Class
1617
1718import Control.Monad.Fix
1819import Control.Monad.IO.Class
src/Reflex/Dom/Widget/Resize.hs+3−3
@@ -5,13 +5,13 @@
55{-# LANGUAGE TypeFamilies #-}
66module Reflex.Dom.Widget.Resize where
77
8−import Reflex
8+import Reflex.Class
99import Reflex.Dom.Builder.Class
1010import Reflex.Dom.Builder.Immediate
1111import Reflex.Dom.Class
12−import Reflex.Dom.PerformEvent.Class
13−import Reflex.Dom.PostBuild.Class
1412import Reflex.Dom.Widget.Basic
13+import Reflex.PerformEvent.Class
14+import Reflex.PostBuild.Class
1515
1616import Control.Monad
1717import Control.Monad.Fix
src/Reflex/Dom/Xhr.hs+2−2
@@ -59,9 +59,9 @@ module Reflex.Dom.Xhr
5959 )
6060where
6161
62−import Reflex
62+import Reflex.Class
6363import Reflex.Dom.Class
64−import Reflex.Dom.PerformEvent.Class
64+import Reflex.PerformEvent.Class
6565import Reflex.Dom.Xhr.Exception
6666import Reflex.Dom.Xhr.Foreign
6767import Reflex.Dom.Xhr.ResponseType