de78254 · reflex-dom · git.iko.soy

git.iko.soy/reflex-dom

on develop help sign in

Merge branch 'develop' of github.com:reflex-frp/reflex-dom into xhrheaders

de78254Greg Hale10 years ago

Quickref.md+19−22

compare with develop

unifiedsplit

@@ -23,41 +23,38 @@ Widgets may return any type (this is 'a' in many of the functions below). Often

23```haskell

24-- Simplest form. Create a widget of given type containing the given child.

25-- Return whatever the child returns.

26−[W] el :: String -> m a -> m a

26+[W] el :: Text -> m a -> m a

28-- 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)

31-- These two additionally apply attributes to the element, such as ("class" =: "blah")

32−[W] elAttr :: String -> Map String String -> m a -> m a

32+[W] elAttr :: Text -> Map Text Text -> m a -> m a

33−[W] elAttr' :: String -> Map String String -> m a -> m (El, a)

33+[W] elAttr' :: Text -> Map Text Text -> m a -> m (El, a)

35-- As above, but now the attribute map is Dynamic

36−[W] elDynAttr :: String -> Dynamic (Map String String) -> m a -> m a

36+[W] elDynAttr :: Text -> Dynamic (Map Text Text) -> m a -> m a

37−[W] elDynAttr' :: String -> Dynamic (Map String String) -> m a -> m (El, a)

37+[W] elDynAttr' :: Text -> Dynamic (Map Text Text) -> m a -> m (El, a)

39-- 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

42-- 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

45-- Create a widget of given type with arbitrary, Dymamic HTML inside.

46−[W] elDynHtml' :: String -> Dynamic String -> m El

46+[W] elDynHtml' :: Text -> Dynamic Text -> m El

47−[W] elDynHtmlAttr' :: String -> Map String String -> Dynamic String -> m El

47+[W] elDynHtmlAttr' :: Text -> Map Text Text -> Dynamic Text -> 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 ()

52-- Create a static text element

49-- Create a static text element

53−[W] text :: String -> m ()

50+[W] text :: Text -> m ()

55-- Create a dynamic text element

52-- Create a dynamic text element

56−[W] dynText :: Dynamic String -> m ()

53+[W] dynText :: Dynamic Text -> m ()

57[W] display :: Show a => Dynamic a -> m ()

54[W] display :: Show a => Dynamic a -> m ()

59-- Create a "button" element with given label, return onClick Event

56-- Create a "button" element with given label, return onClick Event

60−[W] button :: String -> m (Event ())

57+[W] button :: Text -> m (Event ())

62-- Empty widget

59-- Empty widget

63[W] blank :: m ()

60[W] blank :: m ()

@@ -121,13 +118,13 @@ Some of these widget builders take a configuration record and return a record co

121

118

122-- Dropdown with Dynamic options. First argument is initial state.

119-- Dropdown with Dynamic options. First argument is initial state.

123[W] dropdown :: (Ord k, Show k, Read k) =>

120[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)

125

122

126-- Table with static columns and dynamic rows.

123-- Table with static columns and dynamic rows.

127[W] tableDynAttr :: ... -- See Reflex.Dom.Widget.Basic

124[W] tableDynAttr :: ... -- See Reflex.Dom.Widget.Basic

128

125

129-- Tabbed view that shows only one of its child widgets at a time.

126-- 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 ()

131

128

132-- Widget to efficiently display long scrolling lists.

129-- Widget to efficiently display long scrolling lists.

133[W] virtualListWithSelection :: ... -- See Reflex.Dom.Widget.Lazy

130[W] virtualListWithSelection :: ... -- See Reflex.Dom.Widget.Lazy

@@ -163,19 +160,19 @@ Convenience functions for XMLHttpRequest. see Reflex.Dom.Xhr

163

160

164```haskell

161```haskell

165-- Given method, URL, and config record (with default instance), construct a request.

162-- 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

167

164

168-- Given Event of requests, issue them and produce Event of responses.

165-- 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)

170

167

171-- Issue a collection of requests, wait for them ALL to complete, return collected results.

168-- 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))

173

170

174-- Convenience function to decode JSON-encoded responses.

171-- Convenience function to decode JSON-encoded responses.

175[ ] decodeXhrResponse :: FromJSON a => XhrResponse -> Maybe a

172[ ] decodeXhrResponse :: FromJSON a => XhrResponse -> Maybe a

176

173

177-- Simplified interface to "GET" URLs and return decoded results.

174-- 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))

179```

176```

180

177

181### Time

178### Time

reflex-dom.cabal+1−5

@@ -78,16 +78,12 @@ library

78 Reflex.Dom.Builder.Class

79 Reflex.Dom.Builder.Class.Events

80 Reflex.Dom.Builder.Immediate

81+ Reflex.Dom.Builder.InputDisabled

81 Reflex.Dom.Builder.Static

82 Reflex.Dom.Builder.Static

82 Reflex.Dom.Class

83 Reflex.Dom.Class

83− Reflex.Dom.Deletable.Class

84− Reflex.Dom.DynamicWriter

85 Reflex.Dom.Internal

84 Reflex.Dom.Internal

86 Reflex.Dom.Internal.Foreign

85 Reflex.Dom.Internal.Foreign

87 Reflex.Dom.Location

86 Reflex.Dom.Location

88− Reflex.Dom.PerformEvent.Base

89− Reflex.Dom.PerformEvent.Class

90− Reflex.Dom.PostBuild.Class

91 Reflex.Dom.Old

87 Reflex.Dom.Old

92 Reflex.Dom.Time

88 Reflex.Dom.Time

93 Reflex.Dom.WebSocket

89 Reflex.Dom.WebSocket

src-ghc/Reflex/Dom/WebSocket/Foreign.hs+29−15

@@ -1,3 +1,4 @@

1+{-# LANGUAGE TemplateHaskell #-}

1{-# LANGUAGE AllowAmbiguousTypes #-}

2{-# LANGUAGE AllowAmbiguousTypes #-}

2{-# LANGUAGE ConstraintKinds #-}

3{-# LANGUAGE ConstraintKinds #-}

3{-# LANGUAGE FlexibleContexts #-}

4{-# LANGUAGE FlexibleContexts #-}

@@ -32,12 +33,40 @@ import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSStringRef

32import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSValueRef

33import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSValueRef

33import Graphics.UI.Gtk.WebKit.WebView

34import Graphics.UI.Gtk.WebKit.WebView

36+import Foreign.JavaScript.TH

35import Reflex.Dom.Internal.Foreign

37import Reflex.Dom.Internal.Foreign

37data JSWebSocket = JSWebSocket { wsValue :: JSValueRef

39data JSWebSocket = JSWebSocket { wsValue :: JSValueRef

38 , wsContext :: JSContextRef

40 , wsContext :: JSContextRef

39 }

41 }

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+

41newWebSocket :: WebView -> Text -> (ByteString -> IO ()) -> IO () -> IO () -> IO JSWebSocket

70newWebSocket :: WebView -> Text -> (ByteString -> IO ()) -> IO () -> IO () -> IO JSWebSocket

42newWebSocket wv url onMessage onOpen onClose = withWebViewContext wv $ \c -> do

71newWebSocket wv url onMessage onOpen onClose = withWebViewContext wv $ \c -> do

43 url' <- jsvaluemakestring c =<< jsstringcreatewithutf8cstring (T.unpack url)

72 url' <- jsvaluemakestring c =<< jsstringcreatewithutf8cstring (T.unpack url)

@@ -66,18 +95,3 @@ newWebSocket wv url onMessage onOpen onClose = withWebViewContext wv $ \c -> do

66 addCbs <- jsstringcreatewithutf8cstring "this[0]['onmessage'] = this[1]; this[0]['onopen'] = this[2]; this[0]['onclose'] = this[3];"

95 addCbs <- jsstringcreatewithutf8cstring "this[0]['onmessage'] = this[1]; this[0]['onopen'] = this[2]; this[0]['onclose'] = this[3];"

67 _ <- jsevaluatescript c addCbs o nullPtr 1 nullPtr

96 _ <- jsevaluatescript c addCbs o nullPtr 1 nullPtr

68 return $ JSWebSocket ws c

97 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

40instance IsXhrPayload Text where

41 xmlHttpRequestSend xhr = xmlHttpRequestSendPayload xhr . Just

43+instance IsXhrPayload String where

44+ xmlHttpRequestSend xhr = xmlHttpRequestSendPayload xhr . Just . T.pack

45+

43instance IsXhrPayload File where

46instance IsXhrPayload File where

44 xmlHttpRequestSend = error "xmlHttpRequestSend{File}: not implemented"

47 xmlHttpRequestSend = error "xmlHttpRequestSend{File}: not implemented"

src-ghcjs/Reflex/Dom/WebSocket/Foreign.hs+18−8

@@ -10,6 +10,7 @@ import Control.Monad.Reader

10import Data.ByteString (ByteString)

11import qualified Data.ByteString as BS

12import Data.Text (Text)

13+import qualified Data.Text as T (unpack)

13import Data.Text.Encoding

14import Data.Text.Encoding

14import GHCJS.Buffer

15import GHCJS.Buffer

15import GHCJS.DOM.EventM (on)

16import GHCJS.DOM.EventM (on)

@@ -24,6 +25,23 @@ import JavaScript.TypedArray.ArrayBuffer as JS

25data JSWebSocket = JSWebSocket { unWebSocket :: WebSocket }

26data JSWebSocket = JSWebSocket { unWebSocket :: WebSocket }

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+

27newWebSocket :: a -> Text -> (ByteString -> IO ()) -> IO () -> IO () -> IO JSWebSocket

45newWebSocket :: a -> Text -> (ByteString -> IO ()) -> IO () -> IO () -> IO JSWebSocket

28newWebSocket _ url onMessage onOpen onClose = do

46newWebSocket _ url onMessage onOpen onClose = do

29 ws <- GD.newWebSocket url (Just [] :: Maybe [Text])

47 ws <- GD.newWebSocket url (Just [] :: Maybe [Text])

@@ -40,12 +58,4 @@ newWebSocket _ url onMessage onOpen onClose = do

40 _ <- on ws closeEvent $ liftIO onClose

58 _ <- on ws closeEvent $ liftIO onClose

41 return $ JSWebSocket ws

59 return $ JSWebSocket ws

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−

51foreign import javascript safe "new DataView($3,$1,$2)" js_dataView :: Int -> Int -> JSVal -> JSVal

61foreign 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

49instance IsXhrPayload String where

50 sendXhrPayload = sendString

52+instance IsXhrPayload Text where

53+ sendXhrPayload = sendString

54+

52instance IsXhrPayload FormData where

55instance IsXhrPayload FormData where

53 sendXhrPayload = sendFormData

56 sendXhrPayload = sendFormData

src/Foreign/JavaScript/TH.hs+88−12

@@ -21,8 +21,11 @@ module Foreign.JavaScript.TH ( module Foreign.JavaScript.TH

21 ) where

23import Reflex.Class

24−import Reflex.Dom.Deletable.Class

24+import Reflex.Deletable.Class

25+import Reflex.DynamicWriter

26+import Reflex.PerformEvent.Base

25−import Reflex.Dom.PerformEvent.Class

27+import Reflex.PerformEvent.Class

28+import Reflex.PostBuild.Class

26import Reflex.Host.Class

29import Reflex.Host.Class

28import Language.Haskell.TH

31import Language.Haskell.TH

@@ -94,6 +97,18 @@ instance HasWebView m => HasWebView (Strict.StateT r m) where

94 type WebViewPhantom (Strict.StateT r m) = WebViewPhantom m

97 type WebViewPhantom (Strict.StateT r m) = WebViewPhantom m

95 askWebView = lift askWebView

98 askWebView = lift askWebView

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+

97newtype WithWebView x m a = WithWebView { unWithWebView :: ReaderT (WebViewSingleton x) m a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadTrans, MonadException, MonadAsyncException)

112newtype WithWebView x m a = WithWebView { unWithWebView :: ReaderT (WebViewSingleton x) m a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadTrans, MonadException, MonadAsyncException)

113

99instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (WithWebView x m) where

114instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (WithWebView x m) where

@@ -191,6 +206,18 @@ instance HasJS x m => HasJS x (ReaderT r m) where

191 type JSM (ReaderT r m) = JSM m

206 type JSM (ReaderT r m) = JSM m

192 liftJS = lift . liftJS

207 liftJS = lift . liftJS

193

208

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+

194-- | A Monad that is capable of executing JavaScript

221-- | A Monad that is capable of executing JavaScript

195class Monad m => MonadJS x m | m -> x where

222class Monad m => MonadJS x m | m -> x where

196 runJS :: JSFFI -> [JSRef x] -> m (JSRef x)

223 runJS :: JSFFI -> [JSRef x] -> m (JSRef x)

@@ -269,18 +296,13 @@ foreign import javascript unsafe "function(){ return $1(arguments); }" funWithAr

269

296

270#else

297#else

271

298

272−askJSContext :: MonadIO m => WithWebView x m JSContextRef

273−askJSContext = do

274− wv <- askWebView

275− liftIO $ webFrameGetGlobalContext =<< webViewGetMainFrame (unWebViewSingleton wv)

276−

277-- | Make a JS string available that is not wrapped up as a JSValueRef

299-- | Make a JS string available that is not wrapped up as a JSValueRef

278withJSStringRaw :: MonadAsyncException m => String -> (JSStringRef -> m r) -> m r

300withJSStringRaw :: MonadAsyncException m => String -> (JSStringRef -> m r) -> m r

279withJSStringRaw str a = do

301withJSStringRaw str a = do

280 bracket (liftIO $ jsstringcreatewithutf8cstring str) (liftIO . jsstringrelease) $ \strRef -> do

302 bracket (liftIO $ jsstringcreatewithutf8cstring str) (liftIO . jsstringrelease) $ \strRef -> do

281 a strRef

303 a strRef

282

304

283−fromJSNumberRaw :: MonadIO m => JSValueRef -> WithWebView x m Double

305+fromJSNumberRaw :: (MonadIO m, HasJSContext m) => JSValueRef -> m Double

284fromJSNumberRaw val = do

306fromJSNumberRaw val = do

285 jsContext <- askJSContext

307 jsContext <- askJSContext

286 liftIO $ jsvaluetonumber jsContext val nullPtr --TODO: Exceptions

308 liftIO $ jsvaluetonumber jsContext val nullPtr --TODO: Exceptions

@@ -297,15 +319,70 @@ instance MonadIO m => HasJS (JSCtx_JavaScriptCore x) (WithWebView x m) where

297 wv <- askWebView

319 wv <- askWebView

298 liftIO $ runWithWebView a wv

320 liftIO $ runWithWebView a wv

299

321

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+

300instance MonadJS (JSCtx_JavaScriptCore x) (WithWebView x IO) where

351instance 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

301 runJS (JSFFI body) args = do

378 runJS (JSFFI body) args = do

302 jsContext <- askJSContext

379 jsContext <- askJSContext

303 withJSArray args $ \(JSRef_JavaScriptCore this) -> liftIO $ do

380 withJSArray args $ \(JSRef_JavaScriptCore this) -> liftIO $ do

304 result <- bracket (jsstringcreatewithutf8cstring body) jsstringrelease $ \script -> jsevaluatescript jsContext script this nullPtr 1 nullPtr

381 result <- bracket (jsstringcreatewithutf8cstring body) jsstringrelease $ \script -> jsevaluatescript jsContext script this nullPtr 1 nullPtr

305 return $ JSRef_JavaScriptCore result --TODO: Protect and unprotect result

382 return $ JSRef_JavaScriptCore result --TODO: Protect and unprotect result

306 forkJS a = do

383 forkJS a = do

307− wv <- askWebView

384+ c <- askJSContext

308− liftIO $ forkIO $ runWithWebView a wv

385+ liftIO $ forkIO $ runWithJSContext a c

309 mkJSUndefined = do

386 mkJSUndefined = do

310 jsContext <- askJSContext

387 jsContext <- askJSContext

311 fmap JSRef_JavaScriptCore $ liftIO $ jsvaluemakeundefined jsContext

388 fmap JSRef_JavaScriptCore $ liftIO $ jsvaluemakeundefined jsContext

@@ -366,14 +443,13 @@ instance MonadJS (JSCtx_JavaScriptCore x) (WithWebView x IO) where

366 jsContext <- askJSContext

443 jsContext <- askJSContext

367 liftIO $ jsvaluetonumber jsContext val nullPtr --TODO: Exceptions

444 liftIO $ jsvaluetonumber jsContext val nullPtr --TODO: Exceptions

368 mkJSFun a = do

445 mkJSFun a = do

369− wv <- askWebView

370 jsContext <- askJSContext

446 jsContext <- askJSContext

371 cb <- liftIO $ mkJSObjectCallAsFunctionCallback $ \_ _ _ argc argv _ -> do --TODO: Use the exception pointer to handle haskell exceptions

447 cb <- liftIO $ mkJSObjectCallAsFunctionCallback $ \_ _ _ argc argv _ -> do --TODO: Use the exception pointer to handle haskell exceptions

372 args <- forM [0..fromIntegral (argc-1)] $ \n -> do

448 args <- forM [0..fromIntegral (argc-1)] $ \n -> do

373 x <- peekElemOff argv n

449 x <- peekElemOff argv n

374 jsvalueprotect jsContext x

450 jsvalueprotect jsContext x

375 return $ JSRef_JavaScriptCore x --TODO: Unprotect eventually

451 return $ JSRef_JavaScriptCore x --TODO: Unprotect eventually

376− unJSRef_JavaScriptCore <$> runWithWebView (a args) wv

452+ unJSRef_JavaScriptCore <$> runWithJSContext (a args) jsContext

377 cbRef <- liftIO $ jsobjectmakefunctionwithcallback jsContext nullPtr cb

453 cbRef <- liftIO $ jsobjectmakefunctionwithcallback jsContext nullPtr cb

378 liftIO $ jsvalueprotect jsContext cbRef

454 liftIO $ jsvalueprotect jsContext cbRef

379 return $ JSFun $ JSRef_JavaScriptCore cbRef

455 return $ JSFun $ JSRef_JavaScriptCore cbRef

src/Reflex/Dom.hs+1−3

@@ -3,14 +3,12 @@ module Reflex.Dom (module X) where

3import Reflex as X

4import Reflex.Dom.Builder.Class as X

5import Reflex.Dom.Builder.Immediate as X

6+import Reflex.Dom.Builder.InputDisabled as X

6import Reflex.Dom.Builder.Static as X

7import Reflex.Dom.Builder.Static as X

7import Reflex.Dom.Class as X

8import Reflex.Dom.Class as X

8−import Reflex.Dom.DynamicWriter as X

9import Reflex.Dom.Internal as X

10import Reflex.Dom.Location as X

11import Reflex.Dom.Old as X

12−import Reflex.Dom.PerformEvent.Class as X

13−import Reflex.Dom.PostBuild.Class as X

14import Reflex.Dom.Time as X

12import Reflex.Dom.Time as X

15import Reflex.Dom.WebSocket as X

13import Reflex.Dom.WebSocket as X

16import Reflex.Dom.Widget as X

14import Reflex.Dom.Widget as X

src/Reflex/Dom/Builder/Class.hs+215−27

@@ -10,6 +10,7 @@

10{-# LANGUAGE OverloadedStrings #-}

11{-# LANGUAGE PolyKinds #-}

12{-# LANGUAGE RankNTypes #-}

13+{-# LANGUAGE RecursiveDo #-}

13{-# LANGUAGE ScopedTypeVariables #-}

14{-# LANGUAGE ScopedTypeVariables #-}

14{-# LANGUAGE TemplateHaskell #-}

15{-# LANGUAGE TemplateHaskell #-}

15{-# LANGUAGE TypeFamilies #-}

16{-# LANGUAGE TypeFamilies #-}

@@ -17,23 +18,32 @@

17module Reflex.Dom.Builder.Class

18module Reflex.Dom.Builder.Class

18 ( module Reflex.Dom.Builder.Class

19 ( module Reflex.Dom.Builder.Class

19 , module Reflex.Dom.Builder.Class.Events

20 , module Reflex.Dom.Builder.Class.Events

20− , module Reflex.Dom.Deletable.Class

21+ , module Reflex.Deletable.Class

21 ) where

22 ) where

23−import Reflex

24+import Reflex.Class as Reflex

24import Reflex.Dom.Builder.Class.Events

25import 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

27import qualified Control.Category

31import qualified Control.Category

28import Control.Lens hiding (element)

32import Control.Lens hiding (element)

29import Control.Monad.Reader

33import Control.Monad.Reader

34+import Control.Monad.State.Strict

30import Control.Monad.Trans.Control

35import Control.Monad.Trans.Control

31import Data.Default

36import Data.Default

37+import Data.Foldable

32import Data.Functor.Misc

38import Data.Functor.Misc

39+import Data.List.NonEmpty (NonEmpty, nonEmpty)

33import Data.Map (Map)

40import Data.Map (Map)

41+import qualified Data.Map as Map

34import Data.Proxy

42import Data.Proxy

35import Data.Semigroup

43import Data.Semigroup

44+import Data.String

36import Data.Text (Text)

45import Data.Text (Text)

46+import Data.Traversable

37import Data.Type.Coercion

47import Data.Type.Coercion

38import GHC.Exts (Constraint)

48import GHC.Exts (Constraint)

@@ -43,19 +53,97 @@ class Default (EventSpec d EventResult) => DomSpace d where

43 type RawElement d :: *

53 type RawElement d :: *

44 type RawInputElement d :: *

54 type RawInputElement d :: *

45 type RawTextAreaElement d :: *

55 type RawTextAreaElement d :: *

56+ type RawSelectElement d :: *

57+ addEventSpecFlags :: proxy d -> EventName en -> (Maybe (er en) -> EventFlags) -> EventSpec d er -> EventSpec d er

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+

47−-- | @'DomBuilder' t m@ indicates that @m@ is a 'Monad' capable of building dynamic DOM in the 'Reflex' timeline @t@

65+-- | @'DomBuilder' t m@ indicates that @m@ is a 'Monad' capable of building

66+-- dynamic DOM in the 'Reflex' timeline @t@

48class (Monad m, Reflex t, Deletable t m, DomSpace (DomBuilderSpace m)) => DomBuilder t m | m -> t where

67class (Monad m, Reflex t, Deletable t m, DomSpace (DomBuilderSpace m)) => DomBuilder t m | m -> t where

49 type DomBuilderSpace m :: *

68 type DomBuilderSpace m :: *

50 textNode :: TextNodeConfig t -> m (TextNode (DomBuilderSpace m) t)

69 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 #-}

51 element :: Text -> ElementConfig er t m -> m a -> m (Element er (DomBuilderSpace m) t, a)

78 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 #-}

52 -- | Create a placeholder in the DOM, with the ability to insert new DOM before it

88 -- | Create a placeholder in the DOM, with the ability to insert new DOM before it

53 -- 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

89 -- 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

54 placeholder :: PlaceholderConfig above t m -> m (Placeholder above t)

90 placeholder :: PlaceholderConfig above t m -> m (Placeholder above t)

55 inputElement :: InputElementConfig er t m -> m (InputElement er (DomBuilderSpace m) t)

91 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 #-}

56 textAreaElement :: TextAreaElementConfig er t m -> m (TextAreaElement er (DomBuilderSpace m) t)

102 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 #-}

57 placeRawElement :: RawElement (DomBuilderSpace m) -> m ()

127 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 #-}

58 wrapRawElement :: RawElement (DomBuilderSpace m) -> RawElementConfig er t m -> m (Element er (DomBuilderSpace m) t)

136 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 #-}

147

60type Namespace = Text

148type Namespace = Text

149

@@ -75,7 +163,11 @@ data TextNode d t = TextNode

75 { _textNode_raw :: RawTextNode d

163 { _textNode_raw :: RawTextNode d

76 }

164 }

165

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

171

80data Propagation

172data Propagation

81 = Propagation_Continue

173 = Propagation_Continue

@@ -121,15 +213,6 @@ data ElementConfig er t m

121 , _elementConfig_eventSpec :: EventSpec (DomBuilderSpace m) er

213 , _elementConfig_eventSpec :: EventSpec (DomBuilderSpace m) er

122 }

214 }

123

215

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−

133data Element er d t

216data Element er d t

134 = Element { _element_events :: EventSelector t (WrapArg er EventName) --TODO: EventSelector should have two arguments

217 = Element { _element_events :: EventSelector t (WrapArg er EventName) --TODO: EventSelector should have two arguments

135 , _element_raw :: RawElement d

218 , _element_raw :: RawElement d

@@ -219,12 +302,36 @@ instance (Reflex t, DomSpace (DomBuilderSpace m)) => Default (RawElementConfig E

219 , _rawElementConfig_eventSpec = def

302 , _rawElementConfig_eventSpec = def

220 }

303 }

221

304

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

222−makeLenses ''TextNodeConfig

327+ [ ''TextNodeConfig

223−makeLenses ''ElementConfig

328+ , ''ElementConfig

224−makeLenses ''PlaceholderConfig

329+ , ''PlaceholderConfig

225−makeLenses ''InputElementConfig

330+ , ''InputElementConfig

226−makeLenses ''TextAreaElementConfig

331+ , ''TextAreaElementConfig

332+ , ''SelectElementConfig

227−makeLenses ''RawElementConfig

333+ , ''RawElementConfig

334+ ]

228

335

229class CanDeleteSelf t a | a -> t where

336class CanDeleteSelf t a | a -> t where

230 deleteSelf :: Lens' a (Event t ())

337 deleteSelf :: Lens' a (Event t ())

@@ -246,6 +353,14 @@ instance InitialAttributes (ElementConfig er t m) where

246 {-# INLINABLE initialAttributes #-}

353 {-# INLINABLE initialAttributes #-}

247 initialAttributes = elementConfig_initialAttributes

354 initialAttributes = elementConfig_initialAttributes

248

355

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+

249class ModifyAttributes t a | a -> t where

364class ModifyAttributes t a | a -> t where

250 modifyAttributes :: Lens' a (Event t (Map AttributeName (Maybe Text)))

365 modifyAttributes :: Lens' a (Event t (Map AttributeName (Maybe Text)))

251

366

@@ -253,6 +368,14 @@ instance ModifyAttributes t (ElementConfig er t m) where

253 {-# INLINABLE modifyAttributes #-}

368 {-# INLINABLE modifyAttributes #-}

254 modifyAttributes = elementConfig_modifyAttributes

369 modifyAttributes = elementConfig_modifyAttributes

255

370

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+

256instance ModifyAttributes t (RawElementConfig er t m) where

379instance ModifyAttributes t (RawElementConfig er t m) where

257 {-# INLINABLE modifyAttributes #-}

380 {-# INLINABLE modifyAttributes #-}

258 modifyAttributes = rawElementConfig_modifyAttributes

381 modifyAttributes = rawElementConfig_modifyAttributes

@@ -264,6 +387,74 @@ instance HasNamespace (ElementConfig er t m) where

264 {-# INLINABLE namespace #-}

387 {-# INLINABLE namespace #-}

265 namespace = elementConfig_namespace

388 namespace = elementConfig_namespace

266

389

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+

267-- * Convenience functions

458-- * Convenience functions

268

459

269--TODO: Move/replace

460--TODO: Move/replace

@@ -293,6 +484,10 @@ instance Functor1 (TextAreaElementConfig er t) where

293 type Functor1Constraint (TextAreaElementConfig er t) a b = Functor1Constraint (ElementConfig er t) a b

484 type Functor1Constraint (TextAreaElementConfig er t) a b = Functor1Constraint (ElementConfig er t) a b

294 fmap1 f cfg = cfg & textAreaElementConfig_elementConfig %~ fmap1 f

485 fmap1 f cfg = cfg & textAreaElementConfig_elementConfig %~ fmap1 f

295

486

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+

296instance Functor1 (RawElementConfig er t) where

491instance Functor1 (RawElementConfig er t) where

297 type Functor1Constraint (RawElementConfig er t) a b = DomBuilderSpace a ~ DomBuilderSpace b

492 type Functor1Constraint (RawElementConfig er t) a b = DomBuilderSpace a ~ DomBuilderSpace b

298 {-# INLINABLE fmap1 #-}

493 {-# INLINABLE fmap1 #-}

@@ -321,14 +516,7 @@ instance Reflex t => HasDomEvent t (TextAreaElement EventResult d t) en where

321

516

322instance DomBuilder t m => DomBuilder t (ReaderT r m) where

517instance DomBuilder t m => DomBuilder t (ReaderT r m) where

323 type DomBuilderSpace (ReaderT r m) = DomBuilderSpace m

518 type DomBuilderSpace (ReaderT r m) = DomBuilderSpace m

324− {-# INLINABLE textNode #-}

325− textNode = liftTextNode

326− element = liftElement

327 placeholder = liftPlaceholder

519 placeholder = liftPlaceholder

328− inputElement = liftInputElement

329− textAreaElement = liftTextAreaElement

330− placeRawElement = lift . placeRawElement

331− wrapRawElement = liftWrapRawElement

332

520

333type LiftDomBuilder t f m =

521type LiftDomBuilder t f m =

334 ( Reflex t

522 ( Reflex t

src/Reflex/Dom/Builder/Immediate.hs+57−11

@@ -17,10 +17,11 @@

17module Reflex.Dom.Builder.Immediate where

19import Foreign.JavaScript.TH

20−import Reflex

20+import Reflex.Class as Reflex

21+import Reflex.Dynamic

21import Reflex.Dom.Builder.Class

22import Reflex.Dom.Builder.Class

22−import Reflex.Dom.PerformEvent.Class

23+import Reflex.PerformEvent.Class

23−import Reflex.Dom.PostBuild.Class

24+import Reflex.PostBuild.Class

24import Reflex.Host.Class

25import Reflex.Host.Class

26import Control.Concurrent.Chan

27import Control.Concurrent.Chan

@@ -37,6 +38,7 @@ import Data.Dependent.Sum

37import Data.Functor.Misc

38import Data.Functor.Misc

38import Data.IORef

39import Data.IORef

39import Data.Maybe

40import Data.Maybe

41+import Data.Monoid

40import Data.Text (Text)

42import Data.Text (Text)

41import GHCJS.DOM.Document (Document, createDocumentFragment, createElement, createElementNS, createTextNode)

43import GHCJS.DOM.Document (Document, createDocumentFragment, createElement, createElementNS, createTextNode)

42import GHCJS.DOM.Element (getScrollTop, removeAttribute, removeAttributeNS, setAttribute, setAttributeNS)

44import GHCJS.DOM.Element (getScrollTop, removeAttribute, removeAttributeNS, setAttribute, setAttributeNS)

@@ -45,12 +47,14 @@ import qualified GHCJS.DOM.Event as Event

45import GHCJS.DOM.EventM (EventM, event, on)

47import GHCJS.DOM.EventM (EventM, event, on)

46import qualified GHCJS.DOM.EventM as DOM

48import qualified GHCJS.DOM.EventM as DOM

47import qualified GHCJS.DOM.HTMLInputElement as Input

49import qualified GHCJS.DOM.HTMLInputElement as Input

50+import qualified GHCJS.DOM.HTMLSelectElement as Select

48import qualified GHCJS.DOM.HTMLTextAreaElement as TextArea

51import qualified GHCJS.DOM.HTMLTextAreaElement as TextArea

49import GHCJS.DOM.MouseEvent

52import GHCJS.DOM.MouseEvent

50import GHCJS.DOM.Node (appendChild, getOwnerDocument, getParentNode, getPreviousSibling, insertBefore,

53import GHCJS.DOM.Node (appendChild, getOwnerDocument, getParentNode, getPreviousSibling, insertBefore,

51 removeChild, setNodeValue, toNode)

54 removeChild, setNodeValue, toNode)

52import GHCJS.DOM.Types (FocusEvent, IsElement, IsEvent, IsNode, KeyboardEvent, Node, ToDOMString, TouchEvent,

55import GHCJS.DOM.Types (FocusEvent, IsElement, IsEvent, IsNode, KeyboardEvent, Node, ToDOMString, TouchEvent,

56+ WheelEvent, castToHTMLInputElement, castToHTMLSelectElement,

53− WheelEvent, castToHTMLInputElement, castToHTMLTextAreaElement)

57+ castToHTMLTextAreaElement)

54import qualified GHCJS.DOM.Types as DOM

58import qualified GHCJS.DOM.Types as DOM

55import GHCJS.DOM.UIEvent

59import GHCJS.DOM.UIEvent

56import qualified GHCJS.DOM.Window as Window

60import qualified GHCJS.DOM.Window as Window

@@ -131,7 +135,7 @@ newtype EventFilterTriggerRef t er (en :: EventTag) = EventFilterTriggerRef (IOR

131wrap :: forall m er t. SupportsImmediateDomBuilder t m => RawElement GhcjsDomSpace -> RawElementConfig er t (ImmediateDomBuilderT t m) -> ImmediateDomBuilderT t m (Element er GhcjsDomSpace t)

135wrap :: forall m er t. SupportsImmediateDomBuilder t m => RawElement GhcjsDomSpace -> RawElementConfig er t (ImmediateDomBuilderT t m) -> ImmediateDomBuilderT t m (Element er GhcjsDomSpace t)

132wrap e cfg = do

136wrap e cfg = do

133 events <- askEvents

137 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

135 Nothing -> maybe (removeAttribute e n) (setAttribute e n) mv

139 Nothing -> maybe (removeAttribute e n) (setAttribute e n) mv

136 Just ns -> maybe (removeAttributeNS e (Just ns) n) (setAttributeNS e (Just ns) n) mv

140 Just ns -> maybe (removeAttributeNS e (Just ns) n) (setAttributeNS e (Just ns) n) mv

137 eventTriggerRefs :: DMap EventName (EventFilterTriggerRef t er) <- liftIO $ fmap DMap.fromList $ forM (DMap.toList $ _ghcjsEventSpec_filters $ _rawElementConfig_eventSpec cfg) $ \(en :=> GhcjsEventFilter f) -> do

141 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

173 Just e <- ImmediateDomBuilderT $ fmap DOM.castToHTMLElement <$> case cfg ^. namespace of

177 Just e <- ImmediateDomBuilderT $ fmap DOM.castToHTMLElement <$> case cfg ^. namespace of

174 Nothing -> createElement doc (Just elementTag)

178 Nothing -> createElement doc (Just elementTag)

175 Just ens -> createElementNS doc (Just ens) (Just elementTag)

179 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

177 Nothing -> setAttribute e n v

181 Nothing -> setAttribute e n v

178 Just ans -> setAttributeNS e (Just ans) n v

182 Just ans -> setAttributeNS e (Just ans) n v

179 result <- lift $ runImmediateDomBuilderT child $ ImmediateDomBuilderEnv

183 result <- lift $ runImmediateDomBuilderT child $ ImmediateDomBuilderEnv

@@ -199,6 +203,20 @@ instance DomSpace GhcjsDomSpace where

199 type RawElement GhcjsDomSpace = DOM.HTMLElement

203 type RawElement GhcjsDomSpace = DOM.HTMLElement

200 type RawInputElement GhcjsDomSpace = DOM.HTMLInputElement

204 type RawInputElement GhcjsDomSpace = DOM.HTMLInputElement

201 type RawTextAreaElement GhcjsDomSpace = DOM.HTMLTextAreaElement

205 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+ }

202

220

203newtype GhcjsEventFilter er en = GhcjsEventFilter (GhcjsDomEvent en -> IO (EventFlags, IO (Maybe (er en))))

221newtype GhcjsEventFilter er en = GhcjsEventFilter (GhcjsDomEvent en -> IO (EventFlags, IO (Maybe (er en))))

204

222

@@ -294,11 +312,7 @@ instance SupportsImmediateDomBuilder t m => DomBuilder t (ImmediateDomBuilderT t

294 [ valueChangedBySetValue

312 [ valueChangedBySetValue

295 , valueChangedByUI

313 , valueChangedByUI

296 ]

314 ]

297− let initialFocus = False --TODO: Is this correct?

315+ hasFocus <- mkHasFocus e

298− hasFocus <- holdDyn initialFocus $ leftmost

299− [ False <$ Reflex.select (_element_events e) (WrapArg Blur)

300− , True <$ Reflex.select (_element_events e) (WrapArg Focus)

301− ]

302 return $ TextAreaElement

316 return $ TextAreaElement

303 { _textAreaElement_value = v

317 { _textAreaElement_value = v

304 , _textAreaElement_input = valueChangedByUI

318 , _textAreaElement_input = valueChangedByUI

@@ -306,9 +320,41 @@ instance SupportsImmediateDomBuilder t m => DomBuilder t (ImmediateDomBuilderT t

306 , _textAreaElement_element = e

320 , _textAreaElement_element = e

307 , _textAreaElement_raw = domTextAreaElement

321 , _textAreaElement_raw = domTextAreaElement

308 }

322 }

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)

309 placeRawElement = append

347 placeRawElement = append

310 wrapRawElement = wrap

348 wrapRawElement = wrap

311

349

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+

312{-# INLINABLE insertImmediateAbove #-}

358{-# INLINABLE insertImmediateAbove #-}

313insertImmediateAbove :: (Reflex t, IsNode placeholder, PerformEvent t m, MonadIO (Performable m)) => placeholder -> Event t (ImmediateDomBuilderT t (Performable m) a) -> ImmediateDomBuilderT t m (Event t a)

359insertImmediateAbove :: (Reflex t, IsNode placeholder, PerformEvent t m, MonadIO (Performable m)) => placeholder -> Event t (ImmediateDomBuilderT t (Performable m) a) -> ImmediateDomBuilderT t m (Event t a)

314insertImmediateAbove n toInsertAbove = do

360insertImmediateAbove 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

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

32import Data.Monoid

33import Data.Text.Encoding

34import GHC.Generics

35−import Reflex

35+import Reflex.Class

36import Reflex.Dom.Builder.Class

37−import Reflex.Dom.PerformEvent.Base

38−import Reflex.Dom.PerformEvent.Class

39−import Reflex.Dom.PostBuild.Class

40import Reflex.Dom.Widget.Basic (applyMap)

37import Reflex.Dom.Widget.Basic (applyMap)

38+import Reflex.Dynamic

41import Reflex.Host.Class

39import Reflex.Host.Class

40+import Reflex.PerformEvent.Base

41+import Reflex.PerformEvent.Class

42+import Reflex.PostBuild.Class

43+import Reflex.Spider

44newtype StaticDomBuilderT t m a = StaticDomBuilderT

46newtype StaticDomBuilderT t m a = StaticDomBuilderT

@@ -101,6 +103,15 @@ instance (Monad m, Ref m ~ Ref IO, Reflex t) => TriggerEvent t (StaticDomBuilder

101 {-# INLINABLE newEventWithLazyTriggerWithOnComplete #-}

103 {-# INLINABLE newEventWithLazyTriggerWithOnComplete #-}

102 newEventWithLazyTriggerWithOnComplete _ = return never

104 newEventWithLazyTriggerWithOnComplete _ = return never

103

105

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+

104type 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)

115type 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)

105

116

106data StaticDomSpace

117data StaticDomSpace

@@ -121,6 +132,8 @@ instance DomSpace StaticDomSpace where

121 type RawElement StaticDomSpace = ()

132 type RawElement StaticDomSpace = ()

122 type RawInputElement StaticDomSpace = ()

133 type RawInputElement StaticDomSpace = ()

123 type RawTextAreaElement StaticDomSpace = ()

134 type RawTextAreaElement StaticDomSpace = ()

135+ type RawSelectElement StaticDomSpace = ()

136+ addEventSpecFlags _ _ _ _ = StaticEventSpec

124

137

125instance SupportsStaticDomBuilder t m => DomBuilder t (StaticDomBuilderT t m) where

138instance SupportsStaticDomBuilder t m => DomBuilder t (StaticDomBuilderT t m) where

126 type DomBuilderSpace (StaticDomBuilderT t m) = StaticDomSpace

139 type DomBuilderSpace (StaticDomBuilderT t m) = StaticDomSpace

@@ -132,7 +145,7 @@ instance SupportsStaticDomBuilder t m => DomBuilder t (StaticDomBuilderT t m) wh

132 return $ TextNode ()

145 return $ TextNode ()

133 {-# INLINABLE element #-}

146 {-# INLINABLE element #-}

134 element elementTag cfg child = do

147 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) <> "\""

136 es <- newFanEventWithTrigger $ \_ _ -> return (return ())

149 es <- newFanEventWithTrigger $ \_ _ -> return (return ())

137 StaticDomBuilderT $ do

150 StaticDomBuilderT $ do

138 (result, innerHtml) <- lift $ runStaticDomBuilderT child

151 (result, innerHtml) <- lift $ runStaticDomBuilderT child

@@ -177,6 +190,17 @@ instance SupportsStaticDomBuilder t m => DomBuilder t (StaticDomBuilderT t m) wh

177 , _textAreaElement_element = e

190 , _textAreaElement_element = e

178 , _textAreaElement_raw = ()

191 , _textAreaElement_raw = ()

179 }

192 }

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)

180 placeRawElement () = return ()

204 placeRawElement () = return ()

181 wrapRawElement () _ = return $ Element (EventSelector $ const never) ()

205 wrapRawElement () _ = return $ Element (EventSelector $ const never) ()

182

206

src/Reflex/Dom/Class.hs+2−2

@@ -10,8 +10,8 @@ import Reflex.Class

10import Web.KeyCode

12import Foreign.JavaScript.TH

13−import Reflex.Dom.PerformEvent.Class

13+import Reflex.PerformEvent.Class

14−import Reflex.Dom.PostBuild.Class

14+import Reflex.PostBuild.Class

16import Prelude hiding (concat, mapM, mapM_, sequence)

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_)

18import Reflex.Dom.Builder.Immediate

19import Reflex.Dom.Class

20import Reflex.Dom.Internal.Foreign

21−import Reflex.Dom.PerformEvent.Base

21+import Reflex.PerformEvent.Base

22−import Reflex.Dom.PostBuild.Class

22+import Reflex.PostBuild.Class

23import Reflex.Host.Class

24import Reflex.Spider (Global, Spider, SpiderHost, runSpiderHost)

@@ -33,6 +33,7 @@ import Data.Dependent.Sum (DSum (..))

33import Data.IORef

34import Data.Maybe

35import Data.Monoid ((<>))

36+import Data.Text (Text)

36import qualified Data.Text as T

37import qualified Data.Text as T

37import Data.Text.Encoding

38import Data.Text.Encoding

38import GHCJS.DOM hiding (runWebGUI)

39import GHCJS.DOM hiding (runWebGUI)

@@ -103,6 +104,13 @@ attachWidget' rootElement wv w = do

103 _ <- appendChild rootElement $ Just df

104 _ <- appendChild rootElement $ Just df

104 return (result, fc)

105 return (result, fc)

105

106

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+

106data AppInput t = AppInput

114data AppInput t = AppInput

107 { _appInput_window :: Window t

115 { _appInput_window :: Window t

108 }

116 }

src/Reflex/Dom/Old.hs+5−5

@@ -63,12 +63,12 @@ import GHCJS.DOM.NamedNodeMap as NNM

63import GHCJS.DOM.Node (getFirstChild, getNodeName, getParentNode, getPreviousSibling, removeChild, toNode)

64import GHCJS.DOM.Types (IsElement, IsNode)

65import qualified GHCJS.DOM.Types as DOM

66−import Reflex

66+import Reflex.Class

67import Reflex.Dom.Builder.Class

68import Reflex.Dom.Builder.Immediate

69import Reflex.Dom.Internal.Foreign

70−import Reflex.Dom.PerformEvent.Class

70+import Reflex.PerformEvent.Class

71−import Reflex.Dom.PostBuild.Class

71+import Reflex.PostBuild.Class

72import Reflex.Dom.Widget.Basic

73import Reflex.Host.Class

@@ -133,7 +133,7 @@ instance Attributes m (Map Text Text) t where

133

134addStaticAttributes :: Applicative m => Map Text Text -> ElementConfig er t m -> m (ElementConfig er t m)

135addStaticAttributes attrs cfg = do

136− let initialAttrs = Map.fromList $ first ((,) Nothing) <$> Map.toList attrs

136+ let initialAttrs = Map.fromList $ first (AttributeName Nothing) <$> Map.toList attrs

137 pure $ cfg & elementConfig_initialAttributes .~ initialAttrs

138

139instance PostBuild t m => Attributes m (Dynamic t (Map Text Text)) t where

@@ -261,7 +261,7 @@ elStopPropagationNS ns elementTag en child = do

261

262elDynHtmlAttr' :: MonadWidget t m => Text -> Map Text Text -> Dynamic t Text -> m (Element EventResult GhcjsDomSpace t)

263elDynHtmlAttr' elementTag attrs html = do

264− let cfg = def & initialAttributes .~ Map.mapKeys ((,) Nothing) attrs

264+ let cfg = def & initialAttributes .~ Map.mapKeys (AttributeName Nothing) attrs

265 (e, _) <- element elementTag cfg $ return ()

266 postBuild <- getPostBuild

267 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 @@

6{-# LANGUAGE TypeFamilies #-}

7module Reflex.Dom.Time where

9−import Reflex

9+import Reflex.Class

10+import Reflex.Dynamic

10−import Reflex.Dom.PerformEvent.Class

11+import Reflex.PerformEvent.Class

11−import Reflex.Dom.PostBuild.Class

12+import Reflex.PostBuild.Class

13import Control.Concurrent

14import Control.Concurrent

14import qualified Control.Concurrent.Thread.Delay as Concurrent

15import qualified Control.Concurrent.Thread.Delay as Concurrent

src/Reflex/Dom/WebSocket.hs+13−7

@@ -23,10 +23,10 @@ module Reflex.Dom.WebSocket where

24import Prelude hiding (all, concat, concatMap, div, mapM, mapM_, sequence, span)

26−import Reflex

26+import Reflex.Class

27import Reflex.Dom.Class

28−import Reflex.Dom.PerformEvent.Class

28+import Reflex.PerformEvent.Class

29−import Reflex.Dom.PostBuild.Class

29+import Reflex.PostBuild.Class

30import Reflex.Dom.WebSocket.Foreign

32import Control.Concurrent

@@ -42,11 +42,11 @@ import Data.IORef

42import Data.Maybe (isJust)

43import Data.Text

45−data WebSocketConfig t

45+data WebSocketConfig t a

46− = WebSocketConfig { _webSocketConfig_send :: Event t [ByteString]

46+ = WebSocketConfig { _webSocketConfig_send :: Event t [a]

47 }

49−instance Reflex t => Default (WebSocketConfig t) where

49+instance Reflex t => Default (WebSocketConfig t a) where

50 def = WebSocketConfig never

52data WebSocket t

@@ -54,7 +54,13 @@ data WebSocket t

54 , _webSocket_open :: Event t ()

55 }

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+

57−webSocket :: (MonadIO m, MonadIO (Performable m), HasWebView m, PerformEvent t m, TriggerEvent t m, PostBuild t m) => Text -> WebSocketConfig t -> m (WebSocket t)

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)

58webSocket url config = do

64webSocket url config = do

59 wv <- fmap unWebViewSingleton askWebView

65 wv <- fmap unWebViewSingleton askWebView

60 (eRecv, onMessage) <- newTriggerEvent

66 (eRecv, onMessage) <- newTriggerEvent

src/Reflex/Dom/Widget/Basic.hs+5−30

@@ -12,10 +12,12 @@

12{-# LANGUAGE TypeFamilies #-}

13module Reflex.Dom.Widget.Basic where

15+import Reflex.Class as Reflex

15import Reflex.Dom.Builder.Class

16import Reflex.Dom.Builder.Class

16import Reflex.Dom.Class

17import Reflex.Dom.Class

17import Reflex.Dom.Internal.Foreign ()

18import Reflex.Dom.Internal.Foreign ()

18−import Reflex.Dom.PostBuild.Class

19+import Reflex.Dynamic

20+import Reflex.PostBuild.Class

20import Control.Arrow

22import Control.Arrow

21import Control.Lens hiding (children, element)

23import Control.Lens hiding (children, element)

@@ -36,7 +38,6 @@ import qualified Data.Text as T

36import Data.These

38import Data.These

37import Data.Traversable

39import Data.Traversable

38import Prelude hiding (mapM, mapM_, sequence, sequence_)

40import Prelude hiding (mapM, mapM_, sequence, sequence_)

39−import Reflex

41widgetHoldInternal :: DomBuilder t m => m a -> Event t (m b) -> m (a, Event t b)

42widgetHoldInternal :: DomBuilder t m => m a -> Event t (m b) -> m (a, Event t b)

42widgetHoldInternal child0 child' = do

43widgetHoldInternal child0 child' = do

@@ -214,32 +215,6 @@ selectViewListWithKey_ :: forall t m k v a. (DomBuilder t m, Ord k, PostBuild t

214 -> m (Event t k) -- ^ Event that fires when any child's return Event fires. Contains key of an arbitrary firing widget.

215 -> m (Event t k) -- ^ Event that fires when any child's return Event fires. Contains key of an arbitrary firing widget.

215selectViewListWithKey_ selection vals mkChild = fmap fst <$> selectViewListWithKey selection vals mkChild

216selectViewListWithKey_ selection vals mkChild = fmap fst <$> selectViewListWithKey selection vals mkChild

216

217

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−

243{-# INLINABLE el #-}

218{-# INLINABLE el #-}

244el :: forall t m a. DomBuilder t m => Text -> m a -> m a

219el :: forall t m a. DomBuilder t m => Text -> m a -> m a

245el elementTag child = snd <$> el' elementTag child

220el elementTag child = snd <$> el' elementTag child

@@ -267,7 +242,7 @@ el' elementTag = element elementTag def

267{-# INLINABLE elAttr' #-}

242{-# INLINABLE elAttr' #-}

268elAttr' :: forall t m a. DomBuilder t m => Text -> Map Text Text -> m a -> m (Element EventResult (DomBuilderSpace m) t, a)

243elAttr' :: forall t m a. DomBuilder t m => Text -> Map Text Text -> m a -> m (Element EventResult (DomBuilderSpace m) t, a)

269elAttr' elementTag attrs = element elementTag $ def

244elAttr' elementTag attrs = element elementTag $ def

270− & initialAttributes .~ Map.mapKeys (\k -> (Nothing, k)) attrs

245+ & initialAttributes .~ Map.mapKeys (AttributeName Nothing) attrs

271

246

272{-# INLINABLE elClass' #-}

247{-# INLINABLE elClass' #-}

273elClass' :: forall t m a. DomBuilder t m => Text -> Text -> m a -> m (Element EventResult (DomBuilderSpace m) t, a)

248elClass' :: 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

299 That new -> do

274 That new -> do

300 old <- sample $ current d

275 old <- sample $ current d

301 return $ diffMap old new

276 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

303

278

304--------------------------------------------------------------------------------

279--------------------------------------------------------------------------------

305-- Copied and pasted from Reflex.Widget.Class

280-- Copied and pasted from Reflex.Widget.Class

src/Reflex/Dom/Widget/Input.hs+42−38

@@ -34,17 +34,16 @@ import GHCJS.DOM.Element (castToElement)

34import qualified GHCJS.DOM.Element as Element

35import GHCJS.DOM.EventM (on)

36import qualified GHCJS.DOM.FileList as FileList

37−import GHCJS.DOM.HTMLInputElement (HTMLInputElement, castToHTMLInputElement)

37+import GHCJS.DOM.HTMLInputElement (HTMLInputElement)

38−import GHCJS.DOM.HTMLSelectElement (castToHTMLSelectElement)

39−import qualified GHCJS.DOM.HTMLSelectElement as HTMLSelectElement

40−import GHCJS.DOM.HTMLTextAreaElement (HTMLTextAreaElement, castToHTMLTextAreaElement)

38+import GHCJS.DOM.HTMLTextAreaElement (HTMLTextAreaElement)

41import GHCJS.DOM.Types (File)

39import GHCJS.DOM.Types (File)

42−import Reflex

40+import Reflex.Class

41+import Reflex.Dynamic

43import Reflex.Dom.Builder.Class

42import Reflex.Dom.Builder.Class

44import Reflex.Dom.Builder.Immediate

43import Reflex.Dom.Builder.Immediate

45import Reflex.Dom.Class

44import Reflex.Dom.Class

46−import Reflex.Dom.PerformEvent.Class

45+import Reflex.PerformEvent.Class

47−import Reflex.Dom.PostBuild.Class

46+import Reflex.PostBuild.Class

48import Reflex.Dom.Widget.Basic

47import Reflex.Dom.Widget.Basic

49import qualified Text.Read as T

48import qualified Text.Read as T

@@ -58,9 +57,16 @@ data TextInput t

58 , _textInput_keydown :: Event t Int

57 , _textInput_keydown :: Event t Int

59 , _textInput_keyup :: Event t Int

58 , _textInput_keyup :: Event t Int

60 , _textInput_hasFocus :: Dynamic t Bool

59 , _textInput_hasFocus :: Dynamic t Bool

61− , _textInput_element :: HTMLInputElement

60+ , _textInput_builderElement :: InputElement EventResult GhcjsDomSpace t

62 }

61 }

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+

64data TextInputConfig t

70data TextInputConfig t

65 = TextInputConfig { _textInputConfig_inputType :: Text

71 = TextInputConfig { _textInputConfig_inputType :: Text

66 , _textInputConfig_initialValue :: Text

72 , _textInputConfig_initialValue :: Text

@@ -92,12 +98,17 @@ textInput (TextInputConfig inputType initial eSetValue dAttrs) = do

92 , _textInput_keydown = domEvent Keydown i

98 , _textInput_keydown = domEvent Keydown i

93 , _textInput_keyup = domEvent Keyup i

99 , _textInput_keyup = domEvent Keyup i

94 , _textInput_hasFocus = _inputElement_hasFocus i

100 , _textInput_hasFocus = _inputElement_hasFocus i

95− , _textInput_element = castToHTMLInputElement $ _element_raw $ _inputElement_element i

101+ , _textInput_builderElement = i

96 }

102 }

103

104+{-# INLINE textInputGetEnter #-}

98−{-# INLINABLE textInputGetEnter #-}

105+{-# DEPRECATED textInputGetEnter "Use 'keypress Enter' instead" #-}

99textInputGetEnter :: Reflex t => TextInput t -> Event t ()

106textInputGetEnter :: Reflex t => TextInput t -> Event t ()

107+textInputGetEnter = keypress Enter

108+

109+{-# INLINABLE keypress #-}

110+keypress :: (Reflex t, HasDomEvent t e 'KeypressTag, DomEventType e 'KeypressTag ~ Int) => Key -> e -> Event t ()

100−textInputGetEnter i = fmapMaybe (\n -> if keyCodeLookup n == Enter then Just () else Nothing) $ _textInput_keypress i

111+keypress key i = fmapMaybe (\n -> if keyCodeLookup n == key then Just () else Nothing) $ domEvent Keypress i

101

112

102data RangeInputConfig t

113data RangeInputConfig t

103 = RangeInputConfig { _rangeInputConfig_initialValue :: Float

114 = RangeInputConfig { _rangeInputConfig_initialValue :: Float

@@ -135,7 +146,7 @@ rangeInput (RangeInputConfig initial eSetValue dAttrs) = do

135 , _rangeInput_input = read . T.unpack <$> _inputElement_input i

146 , _rangeInput_input = read . T.unpack <$> _inputElement_input i

136 , _rangeInput_mouseup = domEvent Mouseup i

147 , _rangeInput_mouseup = domEvent Mouseup i

137 , _rangeInput_hasFocus = _inputElement_hasFocus i

148 , _rangeInput_hasFocus = _inputElement_hasFocus i

138− , _rangeInput_element = castToHTMLInputElement $ _element_raw $ _inputElement_element i

149+ , _rangeInput_element = _inputElement_raw i

139 }

150 }

140

151

141data TextAreaConfig t

152data TextAreaConfig t

@@ -172,7 +183,7 @@ textArea (TextAreaConfig initial eSet attrs) = do

172 , _textArea_input = _textAreaElement_input i

183 , _textArea_input = _textAreaElement_input i

173 , _textArea_keypress = domEvent Keypress i

184 , _textArea_keypress = domEvent Keypress i

174 , _textArea_hasFocus = _textAreaElement_hasFocus i

185 , _textArea_hasFocus = _textAreaElement_hasFocus i

175− , _textArea_element = castToHTMLTextAreaElement $ _element_raw $ _textAreaElement_element i

186+ , _textArea_element = _textAreaElement_raw i

176 }

187 }

177

188

178data CheckboxConfig t

189data CheckboxConfig t

@@ -202,7 +213,7 @@ checkbox checked config = do

202 i <- inputElement $ def

213 i <- inputElement $ def

203 & inputElementConfig_initialChecked .~ checked

214 & inputElementConfig_initialChecked .~ checked

204 & inputElementConfig_setChecked .~ _checkboxConfig_setValue config

215 & inputElementConfig_setChecked .~ _checkboxConfig_setValue config

205− & inputElementConfig_elementConfig . elementConfig_initialAttributes .~ Map.mapKeys ((,) Nothing) permanentAttrs

216+ & inputElementConfig_elementConfig . elementConfig_initialAttributes .~ Map.mapKeys (AttributeName Nothing) permanentAttrs

206 & inputElementConfig_elementConfig . elementConfig_modifyAttributes .~ modifyAttrs

217 & inputElementConfig_elementConfig . elementConfig_modifyAttributes .~ modifyAttrs

207 return $ Checkbox

218 return $ Checkbox

208 { _checkbox_value = _inputElement_checked i

219 { _checkbox_value = _inputElement_checked i

@@ -279,7 +290,7 @@ checkboxView dAttrs dValue = do

279 elementConfig :: ElementConfig CheckboxViewEventResult t m

290 elementConfig :: ElementConfig CheckboxViewEventResult t m

280 elementConfig = (def :: ElementConfig EventResult t m)

291 elementConfig = (def :: ElementConfig EventResult t m)

281 { _elementConfig_modifyAttributes = modifyAttrs

292 { _elementConfig_modifyAttributes = modifyAttrs

282− , _elementConfig_initialAttributes = Map.mapKeys ((,) Nothing) permanentAttrs

293+ , _elementConfig_initialAttributes = Map.mapKeys (AttributeName Nothing) permanentAttrs

283 , _elementConfig_eventSpec = GhcjsEventSpec

294 , _elementConfig_eventSpec = GhcjsEventSpec

284 { _ghcjsEventSpec_filters = filters

295 { _ghcjsEventSpec_filters = filters

285 , _ghcjsEventSpec_handler = \(en, GhcjsDomEvent evt) -> case en of

296 , _ghcjsEventSpec_handler = \(en, GhcjsDomEvent evt) -> case en of

@@ -407,7 +418,7 @@ regularToDropdownViewEventType en r = case en of

407--TODO: We should allow the user to specify an ordering instead of relying on the ordering of the Map

418--TODO: We should allow the user to specify an ordering instead of relying on the ordering of the Map

408-- | Create a dropdown box

419-- | Create a dropdown box

409-- 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

420-- 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)

411dropdown k0 options (DropdownConfig setK attrs) = do

422dropdown k0 options (DropdownConfig setK attrs) = do

412 optionsWithAddedKeys <- fmap (zipDynWith Map.union options) $ foldDyn Map.union (k0 =: "") $ fmap (=: "") setK

423 optionsWithAddedKeys <- fmap (zipDynWith Map.union options) $ foldDyn Map.union (k0 =: "") $ fmap (=: "") setK

413 defaultKey <- holdDyn k0 setK

424 defaultKey <- holdDyn k0 setK

@@ -415,31 +426,16 @@ dropdown k0 options (DropdownConfig setK attrs) = do

415 let xs = fmap (\(ix, (k, v)) -> ((ix, k), ((ix, k), v))) $ zip [0::Int ..] $ Map.toList os

426 let xs = fmap (\(ix, (k, v)) -> ((ix, k), ((ix, k), v))) $ zip [0::Int ..] $ Map.toList os

416 in (Map.fromList $ map snd xs, Bimap.fromList $ map fst xs)

427 in (Map.fromList $ map snd xs, Bimap.fromList $ map fst xs)

417 modifyAttrs <- dynamicAttributesToModifyAttributes attrs

428 modifyAttrs <- dynamicAttributesToModifyAttributes attrs

418− let cfg = (def :: ElementConfig EventResult t m)

429+ let cfg = def

419− { _elementConfig_modifyAttributes = modifyAttrs

430+ & selectElementConfig_elementConfig . elementConfig_modifyAttributes .~ modifyAttrs

420− , _elementConfig_eventSpec = GhcjsEventSpec

431+ & selectElementConfig_setValue .~ fmap (T.pack . show) (attachPromptlyDynWithMaybe (flip Bimap.lookupR) ixKeys setK)

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

432+ (eRaw, _) <- selectElement cfg $ listWithKey indexedOptions $ \(ix, k) v -> do

434 let optionAttrs = fmap (\dk -> "value" =: T.pack (show ix) <> if dk == k then "selected" =: "selected" else mempty) defaultKey

433 let optionAttrs = fmap (\dk -> "value" =: T.pack (show ix) <> if dk == k then "selected" =: "selected" else mempty) defaultKey

435 elDynAttr "option" optionAttrs $ dynText v

434 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

435+ let lookupSelected ks v = do

439− v <- value

440− key <- T.readMaybe v

436+ key <- T.readMaybe $ T.unpack v

441 Bimap.lookup key ks

437 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

443 let readKey keys mk = fromMaybe k0 $ do

439 let readKey keys mk = fromMaybe k0 $ do

444 k <- mk

440 k <- mk

445 guard $ Bimap.memberR k keys

441 guard $ Bimap.memberR k keys

@@ -514,6 +510,14 @@ class HasValue a where

514 type Value a :: *

510 type Value a :: *

515 value :: a -> Value a

511 value :: a -> Value a

516

512

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+

517instance HasValue (TextArea t) where

521instance HasValue (TextArea t) where

518 type Value (TextArea t) = Dynamic t Text

522 type Value (TextArea t) = Dynamic t Text

519 value = _textArea_value

523 value = _textArea_value

src/Reflex/Dom/Widget/Lazy.hs+4−3

@@ -6,13 +6,14 @@

6{-# LANGUAGE TypeFamilies #-}

7module Reflex.Dom.Widget.Lazy where

9−import Reflex

9+import Reflex.Class

10import Reflex.Dom.Builder.Class

11import Reflex.Dom.Builder.Immediate

12import Reflex.Dom.Class

13−import Reflex.Dom.PerformEvent.Class

14−import Reflex.Dom.PostBuild.Class

15import Reflex.Dom.Widget.Basic

13import Reflex.Dom.Widget.Basic

14+import Reflex.Dynamic

15+import Reflex.PerformEvent.Class

16+import Reflex.PostBuild.Class

17import Control.Monad.Fix

18import Control.Monad.Fix

18import Control.Monad.IO.Class

19import Control.Monad.IO.Class

src/Reflex/Dom/Widget/Resize.hs+3−3

@@ -5,13 +5,13 @@

5{-# LANGUAGE TypeFamilies #-}

6module Reflex.Dom.Widget.Resize where

8−import Reflex

8+import Reflex.Class

9import Reflex.Dom.Builder.Class

10import Reflex.Dom.Builder.Immediate

11import Reflex.Dom.Class

12−import Reflex.Dom.PerformEvent.Class

13−import Reflex.Dom.PostBuild.Class

14import Reflex.Dom.Widget.Basic

12import Reflex.Dom.Widget.Basic

13+import Reflex.PerformEvent.Class

14+import Reflex.PostBuild.Class

16import Control.Monad

17import Control.Monad.Fix

src/Reflex/Dom/Xhr.hs+2−2

@@ -59,9 +59,9 @@ module Reflex.Dom.Xhr

59 )

60where

62−import Reflex

62+import Reflex.Class

63import Reflex.Dom.Class

64−import Reflex.Dom.PerformEvent.Class

64+import Reflex.PerformEvent.Class

65import Reflex.Dom.Xhr.Exception

66import Reflex.Dom.Xhr.Foreign

67import Reflex.Dom.Xhr.ResponseType