5d9433c · reflex-dom · git.iko.soy

git.iko.soy/reflex-dom

on develop help sign in

Merge branch 'jsaddle' into request-animation-frame-everything

5d9433cWill Fancher10 years ago

reflex-dom-core/reflex-dom-core.cabal+4−1

compare with develop

unifiedsplit

@@ -11,7 +11,9 @@ Category: FRP, Web, GUI, HTML, Javascript, Reactive, Reactivity, User Interfaces

11Build-type: Simple

12Cabal-version: >=1.9.2

13-- Deal with https://github.com/haskell/cabal/issues/2544 / https://github.com/haskell/cabal/issues/367

14+extra-source-files: src-ghc/Foreign/JavaScript/Internal/Utils.hs

15+ src-ghcjs/Foreign/JavaScript/Internal/Utils.hs

14−extra-source-files: src/Reflex/Dom/Xhr/Foreign.hs

16+ src/Reflex/Dom/Xhr/Foreign.hs

15 src/Reflex/Dom/WebSocket/Foreign.hs

17 src/Reflex/Dom/WebSocket/Foreign.hs

16 src/Reflex/Dom/Xhr/ResponseType.hs

18 src/Reflex/Dom/Xhr/ResponseType.hs

17 src/Reflex/Dom/Xhr/Exception.hs

19 src/Reflex/Dom/Xhr/Exception.hs

@@ -86,6 +88,7 @@ library

86 exposed-modules:

88 exposed-modules:

87 Foreign.JavaScript.TH

89 Foreign.JavaScript.TH

88 Foreign.JavaScript.Orphans

90 Foreign.JavaScript.Orphans

91+ Foreign.JavaScript.Utils

89 Reflex.Dom.Builder.Class

92 Reflex.Dom.Builder.Class

90 Reflex.Dom.Builder.Class.Events

93 Reflex.Dom.Builder.Class.Events

91 Reflex.Dom.Builder.Immediate

94 Reflex.Dom.Builder.Immediate

reflex-dom-core/src-ghc/Foreign/JavaScript/Internal/Utils.hs+6−2

@@ -1,13 +1,17 @@

1module Foreign.JavaScript.Internal.Utils

2 ( synchronously

3 , freeRequestAnimationFrameCallback

4+ , js_dataView

4 ) where

5 ) where

6−import GHCJS.DOM.Types (JSM, RequestAnimationFrameCallback (..), Callback (..))

7+import GHCJS.DOM.Types (JSM, JSVal, RequestAnimationFrameCallback (..), Callback (..))

7−import Language.Javascript.JSaddle.Object (freeFunction)

8+import Language.Javascript.JSaddle.Object (freeFunction, new, jsg)

9synchronously :: JSM a -> JSM a

10synchronously :: JSM a -> JSM a

10synchronously = id

11synchronously = id

12freeRequestAnimationFrameCallback :: RequestAnimationFrameCallback -> JSM ()

13freeRequestAnimationFrameCallback :: RequestAnimationFrameCallback -> JSM ()

13freeRequestAnimationFrameCallback (RequestAnimationFrameCallback (Callback cb)) = freeFunction cb

14freeRequestAnimationFrameCallback (RequestAnimationFrameCallback (Callback cb)) = freeFunction cb

15+

16+js_dataView :: Int -> Int -> JSVal -> JSM JSVal

17+js_dataView off len ref = new (jsg "DataView") (ref, off, len)

reflex-dom-core/src-ghcjs/Foreign/JavaScript/Internal/Utils.hs+8−1

@@ -1,11 +1,18 @@

1+{-# LANGUAGE ForeignFunctionInterface #-}

2+{-# LANGUAGE JavaScriptFFI #-}

1module Foreign.JavaScript.Internal.Utils

4module Foreign.JavaScript.Internal.Utils

2 ( synchronously

5 ( synchronously

3 , freeRequestAnimationFrameCallback

6 , freeRequestAnimationFrameCallback

7+ , js_dataView

4 ) where

8 ) where

6import GHCJS.Concurrent

10import GHCJS.Concurrent

7−import GHCJS.DOM.Types (JSM, RequestAnimationFrameCallback (..))

11+import GHCJS.DOM.Types (JSVal, JSM, RequestAnimationFrameCallback (..))

8import GHCJS.Foreign.Callback (releaseCallback)

12import GHCJS.Foreign.Callback (releaseCallback)

10freeRequestAnimationFrameCallback :: RequestAnimationFrameCallback -> JSM ()

14freeRequestAnimationFrameCallback :: RequestAnimationFrameCallback -> JSM ()

11freeRequestAnimationFrameCallback (RequestAnimationFrameCallback cb) = releaseCallback cb

15freeRequestAnimationFrameCallback (RequestAnimationFrameCallback cb) = releaseCallback cb

16+

17+foreign import javascript safe "new DataView($3,$1,$2)"

18+ js_dataView :: Int -> Int -> JSVal -> IO JSVal

reflex-dom-core/src/Foreign/JavaScript/TH.hs+1−1

@@ -178,7 +178,7 @@ instance MonadTransControl (WithJSContextSingleton x) where

178 restoreT = defaultRestoreT WithJSContextSingleton

179

180instance PerformEvent t m => PerformEvent t (WithJSContextSingleton x m) where

181− type Performable (WithJSContextSingleton x m) = WithJSContextSingleton x (Performable m)

181+ type Performable (WithJSContextSingleton x m) = WithJSContextSingleton x (Performable m) --TODO: Can we eliminate this wrapper?

182 {-# INLINABLE performEvent_ #-}

183 performEvent_ e = liftWith $ \run -> performEvent_ $ fmap run e

184 {-# INLINABLE performEvent #-}

reflex-dom-core/src/Foreign/JavaScript/Utils.hsnew file+27

@@ -0,0 +1,27 @@

1+module Foreign.JavaScript.Utils

2+ ( bsFromMutableArrayBuffer

3+ , bsToArrayBuffer

4+ ) where

6+import Data.ByteString (ByteString)

7+import qualified Data.ByteString as BS

8+import qualified GHCJS.Buffer as JS

9+import GHCJS.DOM.Types (ArrayBuffer (..))

10+import qualified JavaScript.TypedArray.ArrayBuffer as JS

11+import Language.Javascript.JSaddle.Types (MonadJSM, liftJSM, ghcjsPure, jsval)

12+import Foreign.JavaScript.Internal.Utils (js_dataView)

13+

14+{-# INLINABLE bsFromMutableArrayBuffer #-}

15+bsFromMutableArrayBuffer :: MonadJSM m => JS.MutableArrayBuffer -> m ByteString

16+bsFromMutableArrayBuffer ab = liftJSM $ JS.unsafeFreeze ab >>=

17+ ghcjsPure . JS.createFromArrayBuffer >>= ghcjsPure . JS.toByteString 0 Nothing

18+

19+{-# INLINABLE bsToArrayBuffer #-}

20+bsToArrayBuffer :: MonadJSM m => ByteString -> m ArrayBuffer

21+bsToArrayBuffer bs = liftJSM $ do

22+ (b, off, len) <- ghcjsPure $ JS.fromByteString bs

23+ ArrayBuffer <$> if BS.length bs == 0 --TODO: remove this logic when https://github.com/ghcjs/ghcjs-base/issues/49 is fixed

24+ then JS.create 0 >>= ghcjsPure . JS.getArrayBuffer >>= ghcjsPure . jsval

25+ else do

26+ ref <- ghcjsPure (JS.getArrayBuffer b) >>= ghcjsPure . jsval

27+ js_dataView off len ref

reflex-dom-core/src/Reflex/Dom/Builder/Class.hs+24

@@ -149,6 +149,25 @@ class (Monad m, Reflex t, DomSpace (DomBuilderSpace m), MonadAdjust t m) => DomB

149 { _rawElementConfig_eventSpec = _rawElementConfig_eventSpec cfg

150 }

151 {-# INLINABLE wrapRawElement #-}

152+ notReadyUntil :: Event t a -> m ()

153+ default notReadyUntil :: ( MonadTrans f

154+ , m ~ f m'

155+ , DomBuilder t m'

156+ )

157+ => Event t a -> m ()

158+ notReadyUntil = lift . notReadyUntil

159+ notReady :: m ()

160+ default notReady :: ( MonadTrans f

161+ , m ~ f m'

162+ , DomBuilder t m'

163+ )

164+ => m ()

165+ notReady = lift notReady

166+

167+class DomBuilder t m => MountableDomBuilder t m where

168+ type DomFragment m :: *

169+ buildDomFragment :: m a -> m (DomFragment m, a)

170+ mountDomFragment :: DomFragment m -> Event t (DomFragment m) -> m ()

152

171

153type Namespace = Text

172type Namespace = Text

154

173

@@ -512,6 +531,11 @@ instance (DomBuilder t m, PerformEvent t m, MonadFix m, MonadHold t m) => DomBui

512 type DomBuilderSpace (PostBuildT t m) = DomBuilderSpace m

531 type DomBuilderSpace (PostBuildT t m) = DomBuilderSpace m

513 wrapRawElement e cfg = liftWith $ \run -> wrapRawElement e $ fmap1 run cfg

532 wrapRawElement e cfg = liftWith $ \run -> wrapRawElement e $ fmap1 run cfg

514

533

534+instance (MountableDomBuilder t m, PerformEvent t m, MonadFix m, MonadHold t m) => MountableDomBuilder t (PostBuildT t m) where

535+ type DomFragment (PostBuildT t m) = DomFragment m

536+ buildDomFragment = liftThrough buildDomFragment

537+ mountDomFragment f0 f' = lift $ mountDomFragment f0 f'

538+

515instance (DomBuilder t m, Monoid w, MonadHold t m, MonadFix m) => DomBuilder t (DynamicWriterT t w m) where

539instance (DomBuilder t m, Monoid w, MonadHold t m, MonadFix m) => DomBuilder t (DynamicWriterT t w m) where

516 type DomBuilderSpace (DynamicWriterT t w m) = DomBuilderSpace m

540 type DomBuilderSpace (DynamicWriterT t w m) = DomBuilderSpace m

517 textNode = liftTextNode

541 textNode = liftTextNode

reflex-dom-core/src/Reflex/Dom/Builder/Class/Events.hs+46−62

@@ -14,7 +14,6 @@ import Data.GADT.Compare.TH

14#else

15import Data.GADT.Compare

16 (GOrdering(..), (:~:)(..), GEq(..), GCompare(..))

17−import Control.Monad (ap)

18#endif

17#endif

20data EventTag

19data EventTag

@@ -238,156 +237,141 @@ instance GEq EventName

238 geq Touchcancel Touchcancel = return Refl

237 geq Touchcancel Touchcancel = return Refl

239 geq _ _ = Nothing

238 geq _ _ = Nothing

240

239

241−newtype GComparing a b t = GComparing (Either (GOrdering a b) t)

242−

243−instance Functor (GComparing a b) where fmap f (GComparing x) = GComparing (either Left (Right . f) x)

244−instance Monad (GComparing a b) where

245− return = GComparing . Right

246− GComparing (Left x) >>= f = GComparing (Left x)

247− GComparing (Right x) >>= f = f x

248−instance Applicative (GComparing a b) where

249− pure = return

250− (<*>) = ap

251−

252−runGComparing (GComparing x) = either id id x

253−

254instance GCompare EventName

240instance GCompare EventName

255− where gcompare Abort Abort = runGComparing $ return GEQ

241+ where gcompare Abort Abort = GEQ

256 gcompare Abort _ = GLT

242 gcompare Abort _ = GLT

257 gcompare _ Abort = GGT

243 gcompare _ Abort = GGT

258− gcompare Blur Blur = runGComparing $ return GEQ

244+ gcompare Blur Blur = GEQ

259 gcompare Blur _ = GLT

245 gcompare Blur _ = GLT

260 gcompare _ Blur = GGT

246 gcompare _ Blur = GGT

261− gcompare Change Change = runGComparing $ return GEQ

247+ gcompare Change Change = GEQ

262 gcompare Change _ = GLT

248 gcompare Change _ = GLT

263 gcompare _ Change = GGT

249 gcompare _ Change = GGT

264− gcompare Click Click = runGComparing $ return GEQ

250+ gcompare Click Click = GEQ

265 gcompare Click _ = GLT

251 gcompare Click _ = GLT

266 gcompare _ Click = GGT

252 gcompare _ Click = GGT

267− gcompare Contextmenu Contextmenu = runGComparing $ return GEQ

253+ gcompare Contextmenu Contextmenu = GEQ

268 gcompare Contextmenu _ = GLT

254 gcompare Contextmenu _ = GLT

269 gcompare _ Contextmenu = GGT

255 gcompare _ Contextmenu = GGT

270− gcompare Dblclick Dblclick = runGComparing $ return GEQ

256+ gcompare Dblclick Dblclick = GEQ

271 gcompare Dblclick _ = GLT

257 gcompare Dblclick _ = GLT

272 gcompare _ Dblclick = GGT

258 gcompare _ Dblclick = GGT

273− gcompare Drag Drag = runGComparing $ return GEQ

259+ gcompare Drag Drag = GEQ

274 gcompare Drag _ = GLT

260 gcompare Drag _ = GLT

275 gcompare _ Drag = GGT

261 gcompare _ Drag = GGT

276− gcompare Dragend Dragend = runGComparing $ return GEQ

262+ gcompare Dragend Dragend = GEQ

277 gcompare Dragend _ = GLT

263 gcompare Dragend _ = GLT

278 gcompare _ Dragend = GGT

264 gcompare _ Dragend = GGT

279− gcompare Dragenter Dragenter = runGComparing $ return GEQ

265+ gcompare Dragenter Dragenter = GEQ

280 gcompare Dragenter _ = GLT

266 gcompare Dragenter _ = GLT

281 gcompare _ Dragenter = GGT

267 gcompare _ Dragenter = GGT

282− gcompare Dragleave Dragleave = runGComparing $ return GEQ

268+ gcompare Dragleave Dragleave = GEQ

283 gcompare Dragleave _ = GLT

269 gcompare Dragleave _ = GLT

284 gcompare _ Dragleave = GGT

270 gcompare _ Dragleave = GGT

285− gcompare Dragover Dragover = runGComparing $ return GEQ

271+ gcompare Dragover Dragover = GEQ

286 gcompare Dragover _ = GLT

272 gcompare Dragover _ = GLT

287 gcompare _ Dragover = GGT

273 gcompare _ Dragover = GGT

288− gcompare Dragstart Dragstart = runGComparing $ return GEQ

274+ gcompare Dragstart Dragstart = GEQ

289 gcompare Dragstart _ = GLT

275 gcompare Dragstart _ = GLT

290 gcompare _ Dragstart = GGT

276 gcompare _ Dragstart = GGT

291− gcompare Drop Drop = runGComparing $ return GEQ

277+ gcompare Drop Drop = GEQ

292 gcompare Drop _ = GLT

278 gcompare Drop _ = GLT

293 gcompare _ Drop = GGT

279 gcompare _ Drop = GGT

294− gcompare Error Error = runGComparing $ return GEQ

280+ gcompare Error Error = GEQ

295 gcompare Error _ = GLT

281 gcompare Error _ = GLT

296 gcompare _ Error = GGT

282 gcompare _ Error = GGT

297− gcompare Focus Focus = runGComparing $ return GEQ

283+ gcompare Focus Focus = GEQ

298 gcompare Focus _ = GLT

284 gcompare Focus _ = GLT

299 gcompare _ Focus = GGT

285 gcompare _ Focus = GGT

300− gcompare Input Input = runGComparing $ return GEQ

286+ gcompare Input Input = GEQ

301 gcompare Input _ = GLT

287 gcompare Input _ = GLT

302 gcompare _ Input = GGT

288 gcompare _ Input = GGT

303− gcompare Invalid Invalid = runGComparing $ return GEQ

289+ gcompare Invalid Invalid = GEQ

304 gcompare Invalid _ = GLT

290 gcompare Invalid _ = GLT

305 gcompare _ Invalid = GGT

291 gcompare _ Invalid = GGT

306− gcompare Keydown Keydown = runGComparing $ return GEQ

292+ gcompare Keydown Keydown = GEQ

307 gcompare Keydown _ = GLT

293 gcompare Keydown _ = GLT

308 gcompare _ Keydown = GGT

294 gcompare _ Keydown = GGT

309− gcompare Keypress Keypress = runGComparing $ return GEQ

295+ gcompare Keypress Keypress = GEQ

310 gcompare Keypress _ = GLT

296 gcompare Keypress _ = GLT

311 gcompare _ Keypress = GGT

297 gcompare _ Keypress = GGT

312− gcompare Keyup Keyup = runGComparing $ return GEQ

298+ gcompare Keyup Keyup = GEQ

313 gcompare Keyup _ = GLT

299 gcompare Keyup _ = GLT

314 gcompare _ Keyup = GGT

300 gcompare _ Keyup = GGT

315− gcompare Load Load = runGComparing $ return GEQ

301+ gcompare Load Load = GEQ

316 gcompare Load _ = GLT

302 gcompare Load _ = GLT

317 gcompare _ Load = GGT

303 gcompare _ Load = GGT

318− gcompare Mousedown Mousedown = runGComparing $ return GEQ

304+ gcompare Mousedown Mousedown = GEQ

319 gcompare Mousedown _ = GLT

305 gcompare Mousedown _ = GLT

320 gcompare _ Mousedown = GGT

306 gcompare _ Mousedown = GGT

321− gcompare Mouseenter Mouseenter = runGComparing $ return GEQ

307+ gcompare Mouseenter Mouseenter = GEQ

322 gcompare Mouseenter _ = GLT

308 gcompare Mouseenter _ = GLT

323 gcompare _ Mouseenter = GGT

309 gcompare _ Mouseenter = GGT

324− gcompare Mouseleave Mouseleave = runGComparing $ return GEQ

310+ gcompare Mouseleave Mouseleave = GEQ

325 gcompare Mouseleave _ = GLT

311 gcompare Mouseleave _ = GLT

326 gcompare _ Mouseleave = GGT

312 gcompare _ Mouseleave = GGT

327− gcompare Mousemove Mousemove = runGComparing $ return GEQ

313+ gcompare Mousemove Mousemove = GEQ

328 gcompare Mousemove _ = GLT

314 gcompare Mousemove _ = GLT

329 gcompare _ Mousemove = GGT

315 gcompare _ Mousemove = GGT

330− gcompare Mouseout Mouseout = runGComparing $ return GEQ

316+ gcompare Mouseout Mouseout = GEQ

331 gcompare Mouseout _ = GLT

317 gcompare Mouseout _ = GLT

332 gcompare _ Mouseout = GGT

318 gcompare _ Mouseout = GGT

333− gcompare Mouseover Mouseover = runGComparing $ return GEQ

319+ gcompare Mouseover Mouseover = GEQ

334 gcompare Mouseover _ = GLT

320 gcompare Mouseover _ = GLT

335 gcompare _ Mouseover = GGT

321 gcompare _ Mouseover = GGT

336− gcompare Mouseup Mouseup = runGComparing $ return GEQ

322+ gcompare Mouseup Mouseup = GEQ

337 gcompare Mouseup _ = GLT

323 gcompare Mouseup _ = GLT

338 gcompare _ Mouseup = GGT

324 gcompare _ Mouseup = GGT

339− gcompare Mousewheel Mousewheel = runGComparing $ return GEQ

325+ gcompare Mousewheel Mousewheel = GEQ

340 gcompare Mousewheel _ = GLT

326 gcompare Mousewheel _ = GLT

341 gcompare _ Mousewheel = GGT

327 gcompare _ Mousewheel = GGT

342− gcompare Scroll Scroll = runGComparing $ return GEQ

328+ gcompare Scroll Scroll = GEQ

343 gcompare Scroll _ = GLT

329 gcompare Scroll _ = GLT

344 gcompare _ Scroll = GGT

330 gcompare _ Scroll = GGT

345− gcompare Select Select = runGComparing $ return GEQ

331+ gcompare Select Select = GEQ

346 gcompare Select _ = GLT

332 gcompare Select _ = GLT

347 gcompare _ Select = GGT

333 gcompare _ Select = GGT

348− gcompare Submit Submit = runGComparing $ return GEQ

334+ gcompare Submit Submit = GEQ

349 gcompare Submit _ = GLT

335 gcompare Submit _ = GLT

350 gcompare _ Submit = GGT

336 gcompare _ Submit = GGT

351− gcompare Wheel Wheel = runGComparing $ return GEQ

337+ gcompare Wheel Wheel = GEQ

352 gcompare Wheel _ = GLT

338 gcompare Wheel _ = GLT

353 gcompare _ Wheel = GGT

339 gcompare _ Wheel = GGT

354− gcompare Beforecut Beforecut = runGComparing $ return GEQ

340+ gcompare Beforecut Beforecut = GEQ

355 gcompare Beforecut _ = GLT

341 gcompare Beforecut _ = GLT

356 gcompare _ Beforecut = GGT

342 gcompare _ Beforecut = GGT

357− gcompare Cut Cut = runGComparing $ return GEQ

343+ gcompare Cut Cut = GEQ

358 gcompare Cut _ = GLT

344 gcompare Cut _ = GLT

359 gcompare _ Cut = GGT

345 gcompare _ Cut = GGT

360− gcompare Beforecopy Beforecopy = runGComparing $ return GEQ

346+ gcompare Beforecopy Beforecopy = GEQ

361 gcompare Beforecopy _ = GLT

347 gcompare Beforecopy _ = GLT

362 gcompare _ Beforecopy = GGT

348 gcompare _ Beforecopy = GGT

363− gcompare Copy Copy = runGComparing $ return GEQ

349+ gcompare Copy Copy = GEQ

364 gcompare Copy _ = GLT

350 gcompare Copy _ = GLT

365 gcompare _ Copy = GGT

351 gcompare _ Copy = GGT

366− gcompare Beforepaste Beforepaste = runGComparing $ return GEQ

352+ gcompare Beforepaste Beforepaste = GEQ

367 gcompare Beforepaste _ = GLT

353 gcompare Beforepaste _ = GLT

368 gcompare _ Beforepaste = GGT

354 gcompare _ Beforepaste = GGT

369− gcompare Paste Paste = runGComparing $ return GEQ

355+ gcompare Paste Paste = GEQ

370 gcompare Paste _ = GLT

356 gcompare Paste _ = GLT

371 gcompare _ Paste = GGT

357 gcompare _ Paste = GGT

372− gcompare Reset Reset = runGComparing $ return GEQ

358+ gcompare Reset Reset = GEQ

373 gcompare Reset _ = GLT

359 gcompare Reset _ = GLT

374 gcompare _ Reset = GGT

360 gcompare _ Reset = GGT

375− gcompare Search Search = runGComparing $ return GEQ

361+ gcompare Search Search = GEQ

376 gcompare Search _ = GLT

362 gcompare Search _ = GLT

377 gcompare _ Search = GGT

363 gcompare _ Search = GGT

378− gcompare Selectstart Selectstart = runGComparing $ return GEQ

364+ gcompare Selectstart Selectstart = GEQ

379 gcompare Selectstart _ = GLT

365 gcompare Selectstart _ = GLT

380 gcompare _ Selectstart = GGT

366 gcompare _ Selectstart = GGT

381− gcompare Touchstart Touchstart = runGComparing $ return GEQ

367+ gcompare Touchstart Touchstart = GEQ

382 gcompare Touchstart _ = GLT

368 gcompare Touchstart _ = GLT

383 gcompare _ Touchstart = GGT

369 gcompare _ Touchstart = GGT

384− gcompare Touchmove Touchmove = runGComparing $ return GEQ

370+ gcompare Touchmove Touchmove = GEQ

385 gcompare Touchmove _ = GLT

371 gcompare Touchmove _ = GLT

386 gcompare _ Touchmove = GGT

372 gcompare _ Touchmove = GGT

387− gcompare Touchend Touchend = runGComparing $ return GEQ

373+ gcompare Touchend Touchend = GEQ

388 gcompare Touchend _ = GLT

374 gcompare Touchend _ = GLT

389 gcompare _ Touchend = GGT

375 gcompare _ Touchend = GGT

390− gcompare Touchcancel Touchcancel = runGComparing $ return GEQ

376+ gcompare Touchcancel Touchcancel = GEQ

391− gcompare Touchcancel _ = GLT

392− gcompare _ Touchcancel = GGT

393#endif

377#endif

reflex-dom-core/src/Reflex/Dom/Builder/Immediate.hs+311−93

@@ -5,6 +5,7 @@

5{-# LANGUAGE EmptyDataDecls #-}

6{-# LANGUAGE FlexibleContexts #-}

7{-# LANGUAGE FlexibleInstances #-}

8+{-# LANGUAGE GADTs #-}

8{-# LANGUAGE GeneralizedNewtypeDeriving #-}

9{-# LANGUAGE GeneralizedNewtypeDeriving #-}

9{-# LANGUAGE LambdaCase #-}

10{-# LANGUAGE LambdaCase #-}

10{-# LANGUAGE MultiParamTypeClasses #-}

11{-# LANGUAGE MultiParamTypeClasses #-}

@@ -48,11 +49,11 @@ module Reflex.Dom.Builder.Immediate

48 , Pair1 (..)

49 , Pair1 (..)

49 , Maybe1 (..)

50 , Maybe1 (..)

50 , GhcjsEventSpec (..)

51 , GhcjsEventSpec (..)

52+ , ghcjsEventSpec_filters

53+ , ghcjsEventSpec_handler

51 , GhcjsEventHandler (..)

54 , GhcjsEventHandler (..)

52#ifndef USE_TEMPLATE_HASKELL

55#ifndef USE_TEMPLATE_HASKELL

53 , phantom2

56 , phantom2

54− , ghcjsEventSpec_filters

55− , ghcjsEventSpec_handler

56#endif

57#endif

57 , drawChildUpdate

58 , drawChildUpdate

58 , mkHasFocus

59 , mkHasFocus

@@ -74,8 +75,6 @@ module Reflex.Dom.Builder.Immediate

74 , WindowConfig (..)

75 , WindowConfig (..)

75 , Window (..)

76 , Window (..)

76 , wrapWindow

77 , wrapWindow

77− , ghcjsEventSpec_filters

78− , ghcjsEventSpec_handler

79 ) where

78 ) where

81import Foreign.JavaScript.TH

80import Foreign.JavaScript.TH

@@ -83,6 +82,8 @@ import Reflex.Class as Reflex

83import Reflex.Dom.Builder.Class

82import Reflex.Dom.Builder.Class

84import Reflex.Dynamic

83import Reflex.Dynamic

85import Reflex.Host.Class

84import Reflex.Host.Class

85+import qualified Reflex.Patch.DMap as PatchDMap

86+import qualified Reflex.Patch.DMapWithMove as PatchDMapWithMove

86import Reflex.PerformEvent.Class

87import Reflex.PerformEvent.Class

87import Reflex.PostBuild.Class

88import Reflex.PostBuild.Class

88import Reflex.TriggerEvent.Base hiding (askEvents)

89import Reflex.TriggerEvent.Base hiding (askEvents)

@@ -106,10 +107,12 @@ import Data.Dependent.Sum

106import Data.Functor.Compose

107import Data.Functor.Compose

107import Data.Functor.Constant

108import Data.Functor.Constant

108import Data.Functor.Misc

109import Data.Functor.Misc

110+import Data.Functor.Product

109import Data.IORef

111import Data.IORef

110import qualified Data.Map as Map

112import qualified Data.Map as Map

111import Data.Maybe

113import Data.Maybe

112−import Data.Monoid

114+import Data.Monoid hiding (Product)

115+import Data.Some (Some)

113import qualified Data.Some as Some

116import qualified Data.Some as Some

114import Data.Text (Text)

117import Data.Text (Text)

115import qualified Data.Text as T

118import qualified Data.Text as T

@@ -144,12 +147,14 @@ import Reflex.Requester.Base

144import Reflex.Requester.Class

147import Reflex.Requester.Class

145import Foreign.JavaScript.Internal.Utils

148import Foreign.JavaScript.Internal.Utils

146

149

147−data ImmediateDomBuilderEnv t m

150+data ImmediateDomBuilderEnv t

148 = ImmediateDomBuilderEnv { _immediateDomBuilderEnv_document :: Document

151 = ImmediateDomBuilderEnv { _immediateDomBuilderEnv_document :: Document

149 , _immediateDomBuilderEnv_parent :: Node

152 , _immediateDomBuilderEnv_parent :: Node

153+ , _immediateDomBuilderEnv_unreadyChildren :: IORef Word -- Number of children who still aren't fully rendered

154+ , _immediateDomBuilderEnv_commitAction :: JSM () -- Action to take when all children are ready --TODO: we should probably get rid of this once we invoke it

150 }

155 }

151

156

152−newtype ImmediateDomBuilderT t m a = ImmediateDomBuilderT { unImmediateDomBuilderT :: ReaderT (ImmediateDomBuilderEnv t m) (RequesterT t JSM Identity (TriggerEventT t m)) a }

157+newtype ImmediateDomBuilderT t m a = ImmediateDomBuilderT { unImmediateDomBuilderT :: ReaderT (ImmediateDomBuilderEnv t) (RequesterT t JSM Identity (TriggerEventT t m)) a }

153 deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException)

158 deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException)

154

159

155#ifndef __GHCJS__

160#ifndef __GHCJS__

@@ -164,7 +169,7 @@ instance PrimMonad m => PrimMonad (ImmediateDomBuilderT x m) where

164instance MonadTrans (ImmediateDomBuilderT t) where

169instance MonadTrans (ImmediateDomBuilderT t) where

165 lift = ImmediateDomBuilderT . lift . lift . lift

170 lift = ImmediateDomBuilderT . lift . lift . lift

166

171

167−instance (PerformEvent t m, PrimMonad m) => DomRenderHook t (ImmediateDomBuilderT t m) where

172+instance (Reflex t, PrimMonad m) => DomRenderHook t (ImmediateDomBuilderT t m) where

168 withRenderHook hook (ImmediateDomBuilderT a) = do

173 withRenderHook hook (ImmediateDomBuilderT a) = do

169 e <- ImmediateDomBuilderT ask

174 e <- ImmediateDomBuilderT ask

170 ImmediateDomBuilderT $ lift $ withRequesting $ \rsp -> do

175 ImmediateDomBuilderT $ lift $ withRequesting $ \rsp -> do

@@ -185,7 +190,7 @@ runImmediateDomBuilderT

185 , Ref m ~ IORef

190 , Ref m ~ IORef

186 )

191 )

187 => ImmediateDomBuilderT t m a

192 => ImmediateDomBuilderT t m a

188− -> ImmediateDomBuilderEnv t m

193+ -> ImmediateDomBuilderEnv t

189 -> Chan [DSum (EventTriggerRef t) TriggerInvocation]

194 -> Chan [DSum (EventTriggerRef t) TriggerInvocation]

190 -> m a

195 -> m a

191runImmediateDomBuilderT (ImmediateDomBuilderT a) env eventChan = flip runTriggerEventT eventChan $ do

196runImmediateDomBuilderT (ImmediateDomBuilderT a) env eventChan = flip runTriggerEventT eventChan $ do

@@ -215,6 +220,9 @@ askParent = ImmediateDomBuilderT $ asks _immediateDomBuilderEnv_parent

215askEvents :: Monad m => ImmediateDomBuilderT t m (Chan [DSum (EventTriggerRef t) TriggerInvocation])

220askEvents :: Monad m => ImmediateDomBuilderT t m (Chan [DSum (EventTriggerRef t) TriggerInvocation])

216askEvents = ImmediateDomBuilderT . lift . lift $ TriggerEventT.askEvents

221askEvents = ImmediateDomBuilderT . lift . lift $ TriggerEventT.askEvents

217

222

223+localEnv :: Monad m => (ImmediateDomBuilderEnv t -> ImmediateDomBuilderEnv t) -> ImmediateDomBuilderT t m a -> ImmediateDomBuilderT t m a

224+localEnv f = ImmediateDomBuilderT . local f . unImmediateDomBuilderT

225+

218{-# INLINABLE append #-}

226{-# INLINABLE append #-}

219append :: (IsNode n, MonadJSM m) => n -> ImmediateDomBuilderT t m ()

227append :: (IsNode n, MonadJSM m) => n -> ImmediateDomBuilderT t m ()

220append n = do

228append n = do

@@ -278,7 +286,7 @@ extractUpTo df s e = liftJSM $ do

278 ]

286 ]

279 void $ call f f (df, s, e)

287 void $ call f f (df, s, e)

280

288

281−type SupportsImmediateDomBuilder t m = (Reflex t, MonadJSM m, MonadJSM (Performable m), MonadHold t m, MonadFix m, PerformEvent t m, MonadReflexCreateTrigger t m, MonadRef m, Ref m ~ Ref JSM, MonadAdjust t m, PrimMonad m)

289+type SupportsImmediateDomBuilder t m = (Reflex t, MonadJSM m, MonadJSM (Performable m), MonadHold t m, MonadFix m, MonadReflexCreateTrigger t m, MonadRef m, Ref m ~ Ref JSM, MonadAdjust t m, PrimMonad m)

282

290

283{-# INLINABLE collectUpTo #-}

291{-# INLINABLE collectUpTo #-}

284collectUpTo :: (MonadJSM m, IsNode start, IsNode end) => start -> end -> m DOM.DocumentFragment

292collectUpTo :: (MonadJSM m, IsNode start, IsNode end) => start -> end -> m DOM.DocumentFragment

@@ -299,9 +307,9 @@ newtype EventFilterTriggerRef t er (en :: EventTag) = EventFilterTriggerRef (IOR

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

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

300wrap e cfg = do

308wrap e cfg = do

301 events <- askEvents

309 events <- askEvents

302− mapM_ (requestDomAction_ . fmap (imapM_ $ \(AttributeName mAttrNamespace n) mv -> case mAttrNamespace of

310+ forM_ (_rawElementConfig_modifyAttributes cfg) $ \modifyAttrs -> requestDomAction_ $ ffor modifyAttrs $ imapM_ $ \(AttributeName mAttrNamespace n) mv -> case mAttrNamespace of

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

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

304− Just ns -> maybe (removeAttributeNS e (Just ns) n) (setAttributeNS e (Just ns) n) mv)) (_rawElementConfig_modifyAttributes cfg)

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

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

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

306 triggerRef <- liftIO $ newIORef Nothing

314 triggerRef <- liftIO $ newIORef Nothing

307 _ <- elementOnEventName en e $ do

315 _ <- elementOnEventName en e $ do

@@ -334,20 +342,22 @@ wrap e cfg = do

334 --TODO: I don't think this is quite right: if a new trigger is created between when this is enqueued and when it fires, this may not work quite right

342 --TODO: I don't think this is quite right: if a new trigger is created between when this is enqueued and when it fires, this may not work quite right

335 ref <- newIORef $ Just t

343 ref <- newIORef $ Just t

336 writeChan events [EventTriggerRef ref :=> TriggerInvocation v (return ())])

344 writeChan events [EventTriggerRef ref :=> TriggerInvocation v (return ())])

337− return $ Element es e

345+ return $ Element

346+ { _element_events = es

347+ , _element_raw = e

348+ }

338

349

339{-# INLINABLE makeElement #-}

350{-# INLINABLE makeElement #-}

340makeElement :: forall er t m a. SupportsImmediateDomBuilder t m => Text -> ElementConfig er t (ImmediateDomBuilderT t m) -> ImmediateDomBuilderT t m a -> ImmediateDomBuilderT t m ((Element er GhcjsDomSpace t, a), DOM.Element)

351makeElement :: forall er t m a. SupportsImmediateDomBuilder t m => Text -> ElementConfig er t (ImmediateDomBuilderT t m) -> ImmediateDomBuilderT t m a -> ImmediateDomBuilderT t m ((Element er GhcjsDomSpace t, a), DOM.Element)

341makeElement elementTag cfg child = do

352makeElement elementTag cfg child = do

342 doc <- askDocument

353 doc <- askDocument

343− env <- ImmediateDomBuilderT ask

344 e <- liftJSM $ case cfg ^. namespace of

354 e <- liftJSM $ case cfg ^. namespace of

345 Nothing -> createElementUnchecked doc (Just elementTag)

355 Nothing -> createElementUnchecked doc (Just elementTag)

346 Just ens -> createElementNSUnchecked doc (Just ens) (Just elementTag)

356 Just ens -> createElementNSUnchecked doc (Just ens) (Just elementTag)

347 ImmediateDomBuilderT $ iforM_ (cfg ^. initialAttributes) $ \(AttributeName mAttrNamespace n) v -> case mAttrNamespace of

357 ImmediateDomBuilderT $ iforM_ (cfg ^. initialAttributes) $ \(AttributeName mAttrNamespace n) v -> case mAttrNamespace of

348 Nothing -> lift $ setAttribute e n v

358 Nothing -> lift $ setAttribute e n v

349 Just ans -> lift $ setAttributeNS e (Just ans) n v

359 Just ans -> lift $ setAttributeNS e (Just ans) n v

350− result <- ImmediateDomBuilderT $ lift $ runReaderT (unImmediateDomBuilderT child) $ env

360+ result <- flip localEnv child $ \env -> env

351 { _immediateDomBuilderEnv_parent = toNode e

361 { _immediateDomBuilderEnv_parent = toNode e

352 }

362 }

353 append e

363 append e

@@ -435,7 +445,7 @@ instance SupportsImmediateDomBuilder t m => DomBuilder t (ImmediateDomBuilderT t

435 Input.setValue domInputElement $ Just (cfg ^. inputElementConfig_initialValue)

445 Input.setValue domInputElement $ Just (cfg ^. inputElementConfig_initialValue)

436 v0 <- Input.getValueUnchecked domInputElement

446 v0 <- Input.getValueUnchecked domInputElement

437 let getMyValue = fromMaybe "" <$> Input.getValue domInputElement

447 let getMyValue = fromMaybe "" <$> Input.getValue domInputElement

438− valueChangedByUI <- performEvent $ liftJSM getMyValue <$ Reflex.select (_element_events e) (WrapArg Input)

448+ valueChangedByUI <- requestDomAction $ liftJSM getMyValue <$ Reflex.select (_element_events e) (WrapArg Input)

439 valueChangedBySetValue <- case _inputElementConfig_setValue cfg of

449 valueChangedBySetValue <- case _inputElementConfig_setValue cfg of

440 Nothing -> return never

450 Nothing -> return never

441 Just eSetValue -> requestDomAction $ ffor eSetValue $ \v' -> do

451 Just eSetValue -> requestDomAction $ ffor eSetValue $ \v' -> do

@@ -486,7 +496,7 @@ instance SupportsImmediateDomBuilder t m => DomBuilder t (ImmediateDomBuilderT t

486 TextArea.setValue domTextAreaElement $ Just (cfg ^. textAreaElementConfig_initialValue)

496 TextArea.setValue domTextAreaElement $ Just (cfg ^. textAreaElementConfig_initialValue)

487 v0 <- TextArea.getValueUnchecked domTextAreaElement

497 v0 <- TextArea.getValueUnchecked domTextAreaElement

488 let getMyValue = fromMaybe "" <$> TextArea.getValue domTextAreaElement

498 let getMyValue = fromMaybe "" <$> TextArea.getValue domTextAreaElement

489− valueChangedByUI <- performEvent $ liftJSM getMyValue <$ Reflex.select (_element_events e) (WrapArg Input)

499+ valueChangedByUI <- requestDomAction $ liftJSM getMyValue <$ Reflex.select (_element_events e) (WrapArg Input)

490 valueChangedBySetValue <- case _textAreaElementConfig_setValue cfg of

500 valueChangedBySetValue <- case _textAreaElementConfig_setValue cfg of

491 Nothing -> return never

501 Nothing -> return never

492 Just eSetValue -> requestDomAction $ ffor eSetValue $ \v' -> do

502 Just eSetValue -> requestDomAction $ ffor eSetValue $ \v' -> do

@@ -511,7 +521,7 @@ instance SupportsImmediateDomBuilder t m => DomBuilder t (ImmediateDomBuilderT t

511 Select.setValue domSelectElement $ Just (cfg ^. selectElementConfig_initialValue)

521 Select.setValue domSelectElement $ Just (cfg ^. selectElementConfig_initialValue)

512 Just v0 <- Select.getValue domSelectElement

522 Just v0 <- Select.getValue domSelectElement

513 let getMyValue = fromMaybe "" <$> Select.getValue domSelectElement

523 let getMyValue = fromMaybe "" <$> Select.getValue domSelectElement

514− valueChangedByUI <- performEvent $ liftJSM getMyValue <$ Reflex.select (_element_events e) (WrapArg Change)

524+ valueChangedByUI <- requestDomAction $ liftJSM getMyValue <$ Reflex.select (_element_events e) (WrapArg Change)

515 valueChangedBySetValue <- case _selectElementConfig_setValue cfg of

525 valueChangedBySetValue <- case _selectElementConfig_setValue cfg of

516 Nothing -> return never

526 Nothing -> return never

517 Just eSetValue -> requestDomAction $ ffor eSetValue $ \v' -> do

527 Just eSetValue -> requestDomAction $ ffor eSetValue $ \v' -> do

@@ -532,96 +542,304 @@ instance SupportsImmediateDomBuilder t m => DomBuilder t (ImmediateDomBuilderT t

532 return (wrapped, result)

542 return (wrapped, result)

533 placeRawElement = append

543 placeRawElement = append

534 wrapRawElement = wrap

544 wrapRawElement = wrap

545+ notReadyUntil e = do

546+ eOnce <- headE e

547+ env <- ImmediateDomBuilderT ask

548+ let unreadyChildren = _immediateDomBuilderEnv_unreadyChildren env

549+ liftIO $ modifyIORef' unreadyChildren succ

550+ let ready = do

551+ old <- liftIO $ readIORef unreadyChildren

552+ let new = pred old

553+ liftIO $ writeIORef unreadyChildren $! new

554+ when (new == 0) $ _immediateDomBuilderEnv_commitAction env

555+ requestDomAction_ $ ready <$ eOnce

556+ notReady = do

557+ env <- ImmediateDomBuilderT ask

558+ let unreadyChildren = _immediateDomBuilderEnv_unreadyChildren env

559+ liftIO $ modifyIORef' unreadyChildren succ

560+

561+data FragmentState

562+ = FragmentState_Unmounted

563+ | FragmentState_Mounted (DOM.Text, DOM.Text)

564+

565+data ImmediateDomFragment = ImmediateDomFragment

566+ { _immediateDomFragment_document :: DOM.DocumentFragment

567+ , _immediateDomFragment_state :: IORef FragmentState

568+ }

535

569

570+extractFragment :: MonadJSM m => ImmediateDomFragment -> m ()

571+extractFragment fragment = do

572+ state <- liftIO $ readIORef $ _immediateDomFragment_state fragment

573+ case state of

574+ FragmentState_Unmounted -> return ()

575+ FragmentState_Mounted (before, after) -> do

576+ extractBetweenExclusive (_immediateDomFragment_document fragment) before after

577+ liftIO $ writeIORef (_immediateDomFragment_state fragment) FragmentState_Unmounted

578+

579+instance SupportsImmediateDomBuilder t m => MountableDomBuilder t (ImmediateDomBuilderT t m) where

580+ type DomFragment (ImmediateDomBuilderT t m) = ImmediateDomFragment

581+ buildDomFragment w = do

582+ df <- createDocumentFragmentUnchecked =<< askDocument

583+ result <- flip localEnv w $ \env -> env

584+ { _immediateDomBuilderEnv_parent = toNode df

585+ }

586+ state <- liftIO $ newIORef FragmentState_Unmounted

587+ return (ImmediateDomFragment df state, result)

588+ mountDomFragment fragment setFragment = do

589+ parent <- askParent

590+ extractFragment fragment

591+ before <- textNodeInternal ("" :: Text)

592+ appendChild_ parent $ Just $ _immediateDomFragment_document fragment

593+ after <- textNodeInternal ("" :: Text)

594+ xs <- foldDyn (\new (previous, _) -> (new, Just previous)) (fragment, Nothing) setFragment

595+ requestDomAction_ $ ffor (updated xs) $ \(childFragment, Just previousFragment) -> do

596+ extractFragment previousFragment

597+ extractFragment childFragment

598+ insertBefore (_immediateDomFragment_document childFragment) after

599+ liftIO $ writeIORef (_immediateDomFragment_state childFragment) $ FragmentState_Mounted (before, after)

600+ liftIO $ writeIORef (_immediateDomFragment_state fragment) $ FragmentState_Mounted (before, after)

601+

536−instance (Reflex t, MonadAdjust t m, MonadJSM m, MonadHold t m, PerformEvent t m, MonadJSM (Performable m), MonadFix m, PrimMonad m) => MonadAdjust t (ImmediateDomBuilderT t m) where

602+instance (Reflex t, MonadAdjust t m, MonadJSM m, MonadHold t m, MonadJSM (Performable m), MonadFix m, PrimMonad m) => MonadAdjust t (ImmediateDomBuilderT t m) where

537 runWithReplace a0 a' = do

603 runWithReplace a0 a' = do

538 initialEnv <- ImmediateDomBuilderT ask

604 initialEnv <- ImmediateDomBuilderT ask

539 before <- textNodeInternal ("" :: Text)

605 before <- textNodeInternal ("" :: Text)

606+ let parentUnreadyChildren = _immediateDomBuilderEnv_unreadyChildren initialEnv

607+ haveEverBeenReady <- liftIO $ newIORef False

608+ currentCohort <- liftIO $ newIORef (-1 :: Int) -- Equal to the cohort currently in the DOM

609+ let myCommitAction = do

610+ liftIO (readIORef haveEverBeenReady) >>= \case

611+ True -> return ()

612+ False -> do

613+ liftIO $ writeIORef haveEverBeenReady True

614+ old <- liftIO $ readIORef parentUnreadyChildren

615+ let new = pred old

616+ liftIO $ writeIORef parentUnreadyChildren $! new

617+ when (new == 0) $ _immediateDomBuilderEnv_commitAction initialEnv

540 -- We draw 'after' in this roundabout way to avoid using MonadFix

618 -- We draw 'after' in this roundabout way to avoid using MonadFix

619+ doc <- askDocument

541− after <- createTextNodeUnchecked (_immediateDomBuilderEnv_document initialEnv) ("" :: Text)

620+ after <- createTextNodeUnchecked doc ("" :: Text)

542 let drawInitialChild = do

621 let drawInitialChild = do

622+ unreadyChildren <- liftIO $ newIORef 0

623+ let f = do

543− result <- a0

624+ result <- a0

544− append after

625+ append after

626+ return result

627+ result <- runReaderT (unImmediateDomBuilderT f) $ initialEnv

628+ { _immediateDomBuilderEnv_unreadyChildren = unreadyChildren

629+ , _immediateDomBuilderEnv_commitAction = myCommitAction

630+ }

631+ liftIO $ readIORef unreadyChildren >>= \case

632+ 0 -> writeIORef haveEverBeenReady True

633+ _ -> modifyIORef' parentUnreadyChildren succ

545 return result

634 return result

635+ a'' <- numberOccurrences a'

546− (result0, result') <- ImmediateDomBuilderT $ lift $ runWithReplace (runReaderT (unImmediateDomBuilderT drawInitialChild) initialEnv) $ ffor a' $ \child -> do

636+ (result0, result') <- ImmediateDomBuilderT $ lift $ runWithReplace drawInitialChild $ ffor a'' $ \(cohortId, child) -> do

547− df <- createDocumentFragmentUnchecked $ _immediateDomBuilderEnv_document initialEnv

637+ df <- createDocumentFragmentUnchecked doc

638+ unreadyChildren <- liftIO $ newIORef 0

639+ let commitAction = do

640+ c <- liftIO $ readIORef currentCohort

641+ when (c <= cohortId) $ do -- If a newer cohort has already been committed, just ignore this

642+ deleteBetweenExclusive before after

643+ insertBefore df after

644+ liftIO $ writeIORef currentCohort cohortId

645+ myCommitAction

548 result <- runReaderT (unImmediateDomBuilderT child) $ initialEnv

646 result <- runReaderT (unImmediateDomBuilderT child) $ initialEnv

549 { _immediateDomBuilderEnv_parent = toNode df

647 { _immediateDomBuilderEnv_parent = toNode df

648+ , _immediateDomBuilderEnv_unreadyChildren = unreadyChildren

649+ , _immediateDomBuilderEnv_commitAction = commitAction

550 }

650 }

551− let update = do

651+ liftIO (readIORef unreadyChildren) >>= \case

552− deleteBetweenExclusive before after

652+ 0 -> liftJSM commitAction

553− insertBefore df after

653+ _ -> return () -- Whoever decrements it to 0 will handle it

554− return (result, update)

654+ return result

555− requestDomAction_ $ snd <$> result'

556− return (result0, fst <$> result')

557− traverseDMapWithKeyWithAdjust (f :: forall a. k a -> v a -> ImmediateDomBuilderT t m (v' a)) (dm0 :: DMap k v) dm' = do

558− initialEnv <- ImmediateDomBuilderT ask

559− (children0, children') <- ImmediateDomBuilderT $ lift $ traverseDMapWithKeyWithAdjust (\k v -> drawChildUpdate initialEnv $ f k v) dm0 dm'

560− let result0 = DMap.map (\(Compose (_, _, v)) -> v) children0

561− placeholders0 = weakenDMapWith (\(Compose (_, ph, _)) -> ph) children0

562− result' = ffor children' $ mapPatchDMap $ \(Compose (_, _, r)) -> r

563− placeholders' = fforCheap children' $ weakenPatchDMapWith $ \(Compose (_, ph, _)) -> ph

564− placeholders <- current . incrementalToDynamic <$> holdIncremental placeholders0 placeholders'

565− _ <- DMap.traverseWithKey (\_ (Compose (df, _, _)) -> Constant () <$ append df) children0

566− lastPlaceholder <- textNodeInternal ("" :: Text)

567− requestDomAction_ $ flip push children' $ \(PatchDMap p) -> do

568− phs <- sample placeholders

569− if DMap.null p then return Nothing else return $ Just $ do

570− let g :: DSum k (ComposeMaybe (Compose ((,,) DOM.DocumentFragment DOM.Text) v')) -> JSM ()

571− g (k :=> ComposeMaybe mv) = do

572− let nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (Some.This k) phs

573− forM_ (Map.lookup (Some.This k) phs) $ \thisPlaceholder -> thisPlaceholder `deleteUpTo` nextPlaceholder

574− forM_ mv $ \(Compose (df, _, _)) -> df `insertBefore` nextPlaceholder

575− mapM_ g $ DMap.toList p

576 return (result0, result')

655 return (result0, result')

577− traverseDMapWithKeyWithAdjustWithMove (f :: forall a. k a -> v a -> ImmediateDomBuilderT t m (v' a)) (dm0 :: DMap k v) dm' = do

656+ traverseDMapWithKeyWithAdjust = do

578− initialEnv <- ImmediateDomBuilderT ask

657+ let updateChildUnreadiness (p :: PatchDMap k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v')) old = do

579− (children0, children') <- ImmediateDomBuilderT $ lift $ traverseDMapWithKeyWithAdjustWithMove (\k v -> drawChildUpdate initialEnv $ f k v) dm0 dm'

658+ let new :: forall a. k a -> ComposeMaybe (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v') a -> IO (ComposeMaybe (Constant (IORef (ChildReadyState k))) a)

580− let result0 = DMap.map (\(Compose (_, _, v)) -> v) children0

659+ new k (ComposeMaybe m) = ComposeMaybe <$> case m of

581− placeholders0 = weakenDMapWith (\(Compose (_, ph, _)) -> ph) children0

660+ Nothing -> return Nothing

582− result' = ffor children' $ mapPatchDMapWithMove $ \(Compose (_, _, r)) -> r

661+ Just (Compose (_, _, sRef, _)) -> do

583− placeholders' = fforCheap children' $ weakenPatchDMapWithMoveWith $ \(Compose (_, ph, _)) -> ph

662+ readIORef sRef >>= \case

584− placeholders <- current . incrementalToDynamic <$> holdIncremental placeholders0 placeholders'

663+ ChildReadyState_Ready -> return Nothing -- Delete this child, since it's ready

585− _ <- DMap.traverseWithKey (\_ (Compose (df, _, _)) -> Constant () <$ append df) children0

664+ ChildReadyState_Unready _ -> do

586− lastPlaceholder <- textNodeInternal ("" :: Text)

665+ writeIORef sRef $ ChildReadyState_Unready $ Just $ Some.This k

587− requestDomAction_ $ flip push children' $ \p_ -> do

666+ return $ Just $ Constant sRef

667+ delete _ (Constant sRef) = do

668+ writeIORef sRef $ ChildReadyState_Unready Nothing

669+ return $ Constant ()

670+ p' <- fmap PatchDMap $ DMap.traverseWithKey new $ unPatchDMap p

671+ _ <- DMap.traverseWithKey delete $ PatchDMap.getDeletions p old

672+ return $ applyAlways p' old

673+ hoistTraverseWithKeyWithAdjust traverseDMapWithKeyWithAdjust mapPatchDMap updateChildUnreadiness $ \placeholders lastPlaceholderRef (PatchDMap p) -> do

674+ phs <- liftIO $ readIORef placeholders

675+ forM_ (DMap.toList p) $ \(k :=> ComposeMaybe mv) -> do

676+ lastPlaceholder <- liftIO $ readIORef lastPlaceholderRef

677+ let nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (Some.This k) phs

678+ forM_ (Map.lookup (Some.This k) phs) $ \thisPlaceholder -> thisPlaceholder `deleteUpTo` nextPlaceholder

679+ forM_ mv $ \(Compose (df, _, _, _)) -> df `insertBefore` nextPlaceholder

680+ liftIO $ writeIORef placeholders $! fromMaybe phs $ apply (weakenPatchDMapWith (\(Compose (_, ph, _, _)) -> ph) $ PatchDMap p) phs

681+ traverseDMapWithKeyWithAdjustWithMove = do

682+ let updateChildUnreadiness (p :: PatchDMapWithMove k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v')) old = do

683+ let new :: forall a. k a -> PatchDMapWithMove.NodeInfo k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v') a -> IO (PatchDMapWithMove.NodeInfo k (Constant (IORef (ChildReadyState k))) a)

684+ new k = PatchDMapWithMove.nodeInfoMapFromM $ \case

685+ PatchDMapWithMove.From_Insert (Compose (_, _, sRef, _)) -> do

686+ readIORef sRef >>= \case

687+ ChildReadyState_Ready -> return PatchDMapWithMove.From_Delete

688+ ChildReadyState_Unready _ -> do

689+ writeIORef sRef $ ChildReadyState_Unready $ Just $ Some.This k

690+ return $ PatchDMapWithMove.From_Insert $ Constant sRef

691+ PatchDMapWithMove.From_Delete -> return PatchDMapWithMove.From_Delete

692+ PatchDMapWithMove.From_Move fromKey -> return $ PatchDMapWithMove.From_Move fromKey

693+ deleteOrMove :: forall a. k a -> Product (Constant (IORef (ChildReadyState k))) (ComposeMaybe k) a -> IO (Constant () a)

694+ deleteOrMove _ (Pair (Constant sRef) (ComposeMaybe mToKey)) = do

695+ writeIORef sRef $ ChildReadyState_Unready $ Some.This <$> mToKey -- This will be Nothing if deleting, and Just if moving, so it works out in both cases

696+ return $ Constant ()

697+ p' <- fmap unsafePatchDMapWithMove $ DMap.traverseWithKey new $ unPatchDMapWithMove p

698+ _ <- DMap.traverseWithKey deleteOrMove $ PatchDMapWithMove.getDeletionsAndMoves p old

699+ return $ applyAlways p' old

700+ hoistTraverseWithKeyWithAdjust traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove updateChildUnreadiness $ \placeholders lastPlaceholderRef (p_ :: PatchDMapWithMove k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v')) -> do

588 let p = unPatchDMapWithMove p_

701 let p = unPatchDMapWithMove p_

589− phsBefore <- sample placeholders

702+ phsBefore <- liftIO $ readIORef placeholders

590− if DMap.null p then return Nothing else return $ Just $ do

703+ lastPlaceholder <- liftIO $ readIORef lastPlaceholderRef

591− let collectIfMoved :: forall a. k a -> DMapEdit k (Compose ((,,) DOM.DocumentFragment DOM.Text) v') a -> JSM (Constant (Maybe DOM.DocumentFragment) a)

704+ let collectIfMoved :: forall a. k a -> PatchDMapWithMove.NodeInfo k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v') a -> JSM (Constant (Maybe DOM.DocumentFragment) a)

592− collectIfMoved k e = do

705+ collectIfMoved k e = do

593− let mThisPlaceholder = Map.lookup (Some.This k) phsBefore -- Will be Nothing if this element wasn't present before

706+ let mThisPlaceholder = Map.lookup (Some.This k) phsBefore -- Will be Nothing if this element wasn't present before

594− nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (Some.This k) phsBefore

707+ nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (Some.This k) phsBefore

595− case dmapEditMoved e of

708+ case isJust $ getComposeMaybe $ PatchDMapWithMove._nodeInfo_to e of

596− False -> do

709+ False -> do

597− mapM_ (`deleteUpTo` nextPlaceholder) mThisPlaceholder

710+ mapM_ (`deleteUpTo` nextPlaceholder) mThisPlaceholder

598− return $ Constant Nothing

711+ return $ Constant Nothing

599− True -> do

712+ True -> do

600− Constant <$> mapM (`collectUpTo` nextPlaceholder) mThisPlaceholder

713+ Constant <$> mapM (`collectUpTo` nextPlaceholder) mThisPlaceholder

601− collected <- DMap.traverseWithKey collectIfMoved p

714+ collected <- DMap.traverseWithKey collectIfMoved p

602− let phsAfter = fromMaybe phsBefore $ apply (weakenPatchDMapWithMoveWith (\(Compose (_, ph, _)) -> ph) p_) phsBefore --TODO: Don't recompute this

715+ let !phsAfter = fromMaybe phsBefore $ apply (weakenPatchDMapWithMoveWith (\(Compose (_, ph, _, _)) -> ph) p_) phsBefore --TODO: Don't recompute this

603− let placeFragment :: forall a. k a -> DMapEdit k (Compose ((,,) DOM.DocumentFragment DOM.Text) v') a -> JSM (Constant () a)

716+ let placeFragment :: forall a. k a -> PatchDMapWithMove.NodeInfo k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v') a -> JSM (Constant () a)

604− placeFragment k e = do

717+ placeFragment k e = do

605− let nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (Some.This k) phsAfter

718+ let nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (Some.This k) phsAfter

606− case e of

719+ case PatchDMapWithMove._nodeInfo_from e of

607− DMapEdit_Insert _ (Compose (df, _, _)) -> do

720+ PatchDMapWithMove.From_Insert (Compose (df, _, _, _)) -> do

608− df `insertBefore` nextPlaceholder

721+ df `insertBefore` nextPlaceholder

609− DMapEdit_Delete _ -> do

722+ PatchDMapWithMove.From_Delete -> do

610− return ()

723+ return ()

611− DMapEdit_Move _ fromKey -> do

724+ PatchDMapWithMove.From_Move fromKey -> do

612− Just (Constant mdf) <- return $ DMap.lookup fromKey collected

725+ Just (Constant mdf) <- return $ DMap.lookup fromKey collected

613− mapM_ (`insertBefore` nextPlaceholder) mdf

726+ mapM_ (`insertBefore` nextPlaceholder) mdf

614− return $ Constant ()

727+ return $ Constant ()

615− mapM_ (\(k :=> v) -> void $ placeFragment k v) $ DMap.toDescList p -- We need to go in reverse order here, to make sure the placeholders are in the right spot at the right time

728+ mapM_ (\(k :=> v) -> void $ placeFragment k v) $ DMap.toDescList p -- We need to go in reverse order here, to make sure the placeholders are in the right spot at the right time

616− return ()

729+ liftIO $ writeIORef placeholders $! phsAfter

617− return (result0, result')

730+

618−

731+data ChildReadyState k

732+ = ChildReadyState_Ready

733+ | ChildReadyState_Unready !(Maybe (Some k))

734+ deriving (Show, Read, Eq, Ord)

735+

736+hoistTraverseWithKeyWithAdjust :: forall (k :: * -> *) v v' t m p.

737+ ( MonadAdjust t m

738+ , MonadHold t m

739+ , DMap.GCompare k

740+ , MonadIO (Performable m)

741+ , MonadIO m

742+ , MonadJSM m

743+ , PrimMonad m

744+ , MonadFix m

745+ , Patch (p k v)

746+ , PatchTarget (p k (Constant Int)) ~ DMap k (Constant Int)

747+ , Monoid (p k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v'))

748+ , Patch (p k (Constant Int))

749+ )

750+ => (forall vv vv'.

751+ (forall a. k a -> vv a -> RequesterT t JSM Identity (TriggerEventT t m) (vv' a))

752+ -> DMap k vv

753+ -> Event t (p k vv)

754+ -> RequesterT t JSM Identity (TriggerEventT t m) (DMap k vv', Event t (p k vv'))

755+ ) -- ^ The base monad's traversal

756+ -> (forall vv vv'. (forall a. vv a -> vv' a) -> p k vv -> p k vv') -- ^ A way of mapping over the patch type

757+ -> (p k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v') -> DMap k (Constant (IORef (ChildReadyState k))) -> IO (DMap k (Constant (IORef (ChildReadyState k))))) -- ^ Given a patch for the children DOM elements, produce a patch for the childrens' unreadiness state

758+ -> (IORef (Map.Map (Some.Some k) DOM.Text) -> IORef DOM.Text -> p k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v') -> JSM ()) -- ^ Apply a patch to the DOM

759+ -> (forall a. k a -> v a -> ImmediateDomBuilderT t m (v' a))

760+ -> DMap k v

761+ -> Event t (p k v)

762+ -> ImmediateDomBuilderT t m (DMap k v', Event t (p k v'))

763+hoistTraverseWithKeyWithAdjust base mapPatch updateChildUnreadiness applyDomUpdate_ (f :: forall a. k a -> v a -> ImmediateDomBuilderT t m (v' a)) (dm0 :: DMap k v) dm' = do

764+ initialEnv <- ImmediateDomBuilderT ask

765+ let parentUnreadyChildren = _immediateDomBuilderEnv_unreadyChildren initialEnv

766+ pendingChange :: IORef (DMap k (Constant (IORef (ChildReadyState k))), p k (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v')) <- liftIO $ newIORef mempty

767+ haveEverBeenReady <- liftIO $ newIORef False

768+ placeholders <- liftIO $ newIORef $ error "placeholders not yet initialized"

769+ lastPlaceholderRef <- liftIO $ newIORef $ error "lastPlaceholderRef not yet initialized"

770+ let applyDomUpdate p = do

771+ applyDomUpdate_ placeholders lastPlaceholderRef p

772+ markSelfReady

773+ liftIO $ writeIORef pendingChange $! mempty

774+ markSelfReady = do

775+ liftIO (readIORef haveEverBeenReady) >>= \case

776+ True -> return ()

777+ False -> do

778+ liftIO $ writeIORef haveEverBeenReady True

779+ old <- liftIO $ readIORef parentUnreadyChildren

780+ let new = pred old

781+ liftIO $ writeIORef parentUnreadyChildren $! new

782+ when (new == 0) $ _immediateDomBuilderEnv_commitAction initialEnv

783+ markChildReady :: IORef (ChildReadyState k) -> JSM ()

784+ markChildReady childReadyState = do

785+ liftIO (readIORef childReadyState) >>= \case

786+ ChildReadyState_Ready -> return ()

787+ ChildReadyState_Unready countedAt -> do

788+ liftIO $ writeIORef childReadyState ChildReadyState_Ready

789+ case countedAt of

790+ Nothing -> return ()

791+ Just (Some.This k) -> do -- This child has been counted as unready, so we need to remove it from the unready set

792+ (oldUnready, p) <- liftIO $ readIORef pendingChange

793+ when (not $ DMap.null oldUnready) $ do -- This shouldn't actually ever be null

794+ let newUnready = DMap.delete k oldUnready

795+ liftIO $ writeIORef pendingChange (newUnready, p)

796+ when (DMap.null newUnready) $ do

797+ applyDomUpdate p

798+ (children0, children') <- ImmediateDomBuilderT $ lift $ base (\k v -> drawChildUpdate initialEnv markChildReady $ f k v) dm0 dm'

799+ let processChild k (Compose (_, _, sRef, _)) = ComposeMaybe <$> do

800+ readIORef sRef >>= \case

801+ ChildReadyState_Ready -> return Nothing

802+ ChildReadyState_Unready _ -> do

803+ writeIORef sRef $ ChildReadyState_Unready $ Just $ Some.This k

804+ return $ Just $ Constant sRef

805+ initialUnready <- liftIO $ DMap.mapMaybeWithKey (\_ -> getComposeMaybe) <$> DMap.traverseWithKey processChild children0

806+ liftIO $ if DMap.null initialUnready

807+ then writeIORef haveEverBeenReady True

808+ else do

809+ modifyIORef' parentUnreadyChildren succ

810+ writeIORef pendingChange (initialUnready, mempty) -- The patch is always empty because it got applied implicitly when we ran the children the first time

811+ let result0 = DMap.map (\(Compose (_, _, _, v)) -> v) children0

812+ placeholders0 = weakenDMapWith (\(Compose (_, ph, _, _)) -> ph) children0

813+ result' = ffor children' $ mapPatch $ \(Compose (_, _, _, r)) -> r

814+ liftIO $ writeIORef placeholders $! placeholders0

815+ _ <- DMap.traverseWithKey (\_ (Compose (df, _, _, _)) -> Constant () <$ append df) children0

816+ liftIO . writeIORef lastPlaceholderRef =<< textNodeInternal ("" :: Text)

817+ requestDomAction_ $ ffor children' $ \p -> do

818+ (oldUnready, oldP) <- liftIO $ readIORef pendingChange

819+ newUnready <- liftIO $ updateChildUnreadiness p oldUnready

820+ let !newP = p <> oldP

821+ liftIO $ writeIORef pendingChange (newUnready, newP)

822+ when (DMap.null newUnready) $ do

823+ applyDomUpdate newP

824+ return (result0, result')

825+

826+drawChildUpdate :: (MonadIO m, MonadJSM m)

827+ => ImmediateDomBuilderEnv t

828+ -> (IORef (ChildReadyState k) -> JSM ()) -- This will NOT be called if the child is ready at initialization time; instead, the ChildReadyState return value will be ChildReadyState_Ready

829+ -> ImmediateDomBuilderT t m (v' a)

619−drawChildUpdate :: (MonadJSM m, PerformEvent t m, MonadFix m, MonadJSM (Performable m)) => ImmediateDomBuilderEnv t m -> ImmediateDomBuilderT t m (v' a) -> RequesterT t JSM Identity (TriggerEventT t m) (Compose ((,,) DOM.DocumentFragment DOM.Text) v' a)

830+ -> RequesterT t JSM Identity (TriggerEventT t m) (Compose ((,,,) DOM.DocumentFragment DOM.Text (IORef (ChildReadyState k))) v' a)

620−drawChildUpdate initialEnv child = do

831+drawChildUpdate initialEnv markReady child = do

832+ childReadyState <- liftIO $ newIORef $ ChildReadyState_Unready Nothing

833+ unreadyChildren <- liftIO $ newIORef 0

621 df <- createDocumentFragmentUnchecked $ _immediateDomBuilderEnv_document initialEnv

834 df <- createDocumentFragmentUnchecked $ _immediateDomBuilderEnv_document initialEnv

622− runReaderT (unImmediateDomBuilderT $ Compose <$> ((,,) <$> pure df <*> textNodeInternal ("" :: Text) <*> child)) $ initialEnv

835+ (placeholder, result) <- runReaderT (unImmediateDomBuilderT $ (,) <$> textNodeInternal ("" :: Text) <*> child) $ initialEnv

623 { _immediateDomBuilderEnv_parent = toNode df

836 { _immediateDomBuilderEnv_parent = toNode df

837+ , _immediateDomBuilderEnv_unreadyChildren = unreadyChildren

838+ , _immediateDomBuilderEnv_commitAction = markReady childReadyState

624 }

839 }

840+ u <- liftIO $ readIORef unreadyChildren

841+ when (u == 0) $ liftIO $ writeIORef childReadyState ChildReadyState_Ready

842+ return $ Compose (df, placeholder, childReadyState, result)

625

843

626mkHasFocus :: (MonadHold t m, Reflex t) => Element er d t -> m (Dynamic t Bool)

844mkHasFocus :: (MonadHold t m, Reflex t) => Element er d t -> m (Dynamic t Bool)

627mkHasFocus e = do

845mkHasFocus e = do

reflex-dom-core/src/Reflex/Dom/Builder/Static.hs+44−16

@@ -150,21 +150,43 @@ instance (Reflex t, MonadAdjust t m, MonadHold t m) => MonadAdjust t (StaticDomB

150 o <- hold (snd result0) $ fmapCheap snd result'

151 StaticDomBuilderT $ modify $ (:) $ join o

152 return (fst result0, fmapCheap fst result')

153− traverseDMapWithKeyWithAdjust f (dm0 :: DMap k v) dm' = do

153+ traverseDMapWithKeyWithAdjust = hoistDMapWithKeyWithAdjust traverseDMapWithKeyWithAdjust mapPatchDMap

154+ traverseDMapWithKeyWithAdjustWithMove = hoistDMapWithKeyWithAdjust traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove

155+

156+hoistDMapWithKeyWithAdjust :: forall (k :: * -> *) v v' t m p.

157+ ( MonadAdjust t m

158+ , MonadHold t m

159+ , DMap.GCompare k

160+ , Patch (p k v)

161+ , PatchTarget (p k (Constant (Behavior t Builder))) ~ DMap k (Constant (Behavior t Builder))

162+ , Patch (p k (Constant (Behavior t Builder)))

163+ )

164+ => (forall vv vv'.

165+ (forall a. k a -> vv a -> m (vv' a))

166+ -> DMap k vv

167+ -> Event t (p k vv)

168+ -> m (DMap k vv', Event t (p k vv'))

169+ ) -- ^ The base monad's traversal

170+ -> (forall vv vv'. (forall a. vv a -> vv' a) -> p k vv -> p k vv') -- ^ A way of mapping over the patch type

171+ -> (forall a. k a -> v a -> StaticDomBuilderT t m (v' a))

172+ -> DMap k v

173+ -> Event t (p k v)

174+ -> StaticDomBuilderT t m (DMap k v', Event t (p k v'))

175+hoistDMapWithKeyWithAdjust base mapPatch f dm0 dm' = do

154− e <- StaticDomBuilderT ask

176+ e <- StaticDomBuilderT ask

155− (children0, children') <- lift $ traverseDMapWithKeyWithAdjust (\k v -> fmap (Compose . swap) (runStaticDomBuilderT (f k v) e)) dm0 dm'

177+ (children0, children') <- lift $ base (\k v -> fmap (Compose . swap) (runStaticDomBuilderT (f k v) e)) dm0 dm'

156− let result0 = DMap.map (snd . getCompose) children0

178+ let result0 = DMap.map (snd . getCompose) children0

157− result' = ffor children' $ mapPatchDMap $ snd . getCompose

179+ result' = ffor children' $ mapPatch $ snd . getCompose

158− outputs0 :: DMap k (Constant (Behavior t Builder))

180+ outputs0 :: DMap k (Constant (Behavior t Builder))

159− outputs0 = DMap.map (Constant . fst . getCompose) children0

181+ outputs0 = DMap.map (Constant . fst . getCompose) children0

160− outputs' :: Event t (PatchDMap k (Constant (Behavior t Builder)))

182+ outputs' :: Event t (p k (Constant (Behavior t Builder)))

161− outputs' = ffor children' $ mapPatchDMap $ Constant . fst . getCompose

183+ outputs' = ffor children' $ mapPatch $ Constant . fst . getCompose

162− outputs <- holdIncremental outputs0 outputs'

184+ outputs <- holdIncremental outputs0 outputs'

163− StaticDomBuilderT $ modify $ (:) $ pull $ do

185+ StaticDomBuilderT $ modify $ (:) $ pull $ do

164− os <- sample $ currentIncremental outputs

186+ os <- sample $ currentIncremental outputs

165− fmap mconcat $ forM (DMap.toList os) $ \(_ :=> Constant o) -> do

187+ fmap mconcat $ forM (DMap.toList os) $ \(_ :=> Constant o) -> do

166− sample o

188+ sample o

167− return (result0, result')

189+ return (result0, result')

168

190

169-- TODO: the uses of illegal lenses in this instance causes it to be somewhat less efficient than it can be. replacing them with explicit cases to get the underlying Maybe Event and working with those is ideal.

191-- TODO: the uses of illegal lenses in this instance causes it to be somewhat less efficient than it can be. replacing them with explicit cases to get the underlying Maybe Event and working with those is ideal.

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

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

@@ -204,7 +226,11 @@ instance SupportsStaticDomBuilder t m => DomBuilder t (StaticDomBuilderT t m) wh

204 let open = mconcat [constant ("<" <> byteString tagBS), attrs2, constant (byteString ">")]

226 let open = mconcat [constant ("<" <> byteString tagBS), attrs2, constant (byteString ">")]

205 let close = constant $ byteString $ "</" <> tagBS <> ">"

227 let close = constant $ byteString $ "</" <> tagBS <> ">"

206 modify $ (:) $ mconcat [open, innerHtml, close]

228 modify $ (:) $ mconcat [open, innerHtml, close]

207− return (Element es (), result)

229+ let e = Element

230+ { _element_events = es

231+ , _element_raw = ()

232+ }

233+ return (e, result)

208 {-# INLINABLE inputElement #-}

234 {-# INLINABLE inputElement #-}

209 inputElement cfg = do

235 inputElement cfg = do

210 (e, _result) <- element "input" (cfg ^. inputElementConfig_elementConfig) $ return ()

236 (e, _result) <- element "input" (cfg ^. inputElementConfig_elementConfig) $ return ()

@@ -250,6 +276,8 @@ instance SupportsStaticDomBuilder t m => DomBuilder t (StaticDomBuilderT t m) wh

250 return (wrapped, result)

276 return (wrapped, result)

251 placeRawElement () = return ()

277 placeRawElement () = return ()

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

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

279+ notReadyUntil _ = return () --TODO: Do we need to support this somehow?

280+ notReady = return () --TODO: Do we need to support this somehow?

253

281

254--TODO: Make this more abstract --TODO: Put the WithWebView underneath PerformEventT - I think this would perform better

282--TODO: Make this more abstract --TODO: Put the WithWebView underneath PerformEventT - I think this would perform better

255type StaticWidget x = PostBuildT Spider (StaticDomBuilderT Spider (PerformEventT Spider (SpiderHost Global)))

283type StaticWidget x = PostBuildT Spider (StaticDomBuilderT Spider (PerformEventT Spider (SpiderHost Global)))

reflex-dom-core/src/Reflex/Dom/Main.hs+6

@@ -90,9 +90,12 @@ mainWidgetWithHead' widgets = withJSContextSingletonMono $ \jsSing -> do

90 (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef

91 let go :: forall c. Widget () c -> DOM.DocumentFragment -> PerformEventT Spider (SpiderHost Global) c

92 go w df = do

93+ unreadyChildren <- liftIO $ newIORef 0

93 let builderEnv = ImmediateDomBuilderEnv

94 let builderEnv = ImmediateDomBuilderEnv

94 { _immediateDomBuilderEnv_document = toDocument doc

95 { _immediateDomBuilderEnv_document = toDocument doc

95 , _immediateDomBuilderEnv_parent = toNode df

96 , _immediateDomBuilderEnv_parent = toNode df

97+ , _immediateDomBuilderEnv_unreadyChildren = unreadyChildren

98+ , _immediateDomBuilderEnv_commitAction = return () --TODO

96 }

99 }

97 runWithJSContextSingleton (runImmediateDomBuilderT (runPostBuildT w postBuild) builderEnv events) jsSing

100 runWithJSContextSingleton (runImmediateDomBuilderT (runPostBuildT w postBuild) builderEnv events) jsSing

98 rec b <- go (headWidget a) headFragment

101 rec b <- go (headWidget a) headFragment

@@ -115,9 +118,12 @@ attachWidget' rootElement jsSing w = do

115 df <- createDocumentFragmentUnchecked doc

118 df <- createDocumentFragmentUnchecked doc

116 ((a, events), fc) <- liftIO . attachWidget'' $ \events -> do

119 ((a, events), fc) <- liftIO . attachWidget'' $ \events -> do

117 (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef

120 (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef

121+ unreadyChildren <- liftIO $ newIORef 0

118 let builderEnv = ImmediateDomBuilderEnv

122 let builderEnv = ImmediateDomBuilderEnv

119 { _immediateDomBuilderEnv_document = toDocument doc

123 { _immediateDomBuilderEnv_document = toDocument doc

120 , _immediateDomBuilderEnv_parent = toNode df

124 , _immediateDomBuilderEnv_parent = toNode df

125+ , _immediateDomBuilderEnv_unreadyChildren = unreadyChildren

126+ , _immediateDomBuilderEnv_commitAction = return () --TODO

121 }

127 }

122 a <- runWithJSContextSingleton (runImmediateDomBuilderT (runPostBuildT w postBuild) builderEnv events) jsSing

128 a <- runWithJSContextSingleton (runImmediateDomBuilderT (runPostBuildT w postBuild) builderEnv events) jsSing

123 return ((a, events), postBuildTriggerRef)

129 return ((a, events), postBuildTriggerRef)

reflex-dom-core/src/Reflex/Dom/WebSocket/Foreign.hs+4−22

@@ -14,24 +14,18 @@ import Prelude hiding (all, concat, concatMap, div, mapM, mapM_, sequence, span)

15import Control.Monad.Reader

16import Data.ByteString (ByteString)

17−import qualified Data.ByteString as BS

18import Data.Text (Text)

17import Data.Text (Text)

19import qualified Data.Text as T (unpack)

18import qualified Data.Text as T (unpack)

20import Data.Text.Encoding

19import Data.Text.Encoding

21−import GHCJS.Buffer

20+import Foreign.JavaScript.Utils (bsFromMutableArrayBuffer, bsToArrayBuffer)

22import GHCJS.DOM.CloseEvent

21import GHCJS.DOM.CloseEvent

23import GHCJS.DOM.EventM (on)

22import GHCJS.DOM.EventM (on)

24import GHCJS.DOM.MessageEvent

23import GHCJS.DOM.MessageEvent

25import GHCJS.DOM.Types hiding (Text)

24import GHCJS.DOM.Types hiding (Text)

26import qualified GHCJS.DOM.WebSocket as GD

25import qualified GHCJS.DOM.WebSocket as GD

27import GHCJS.Foreign (JSType(..), jsTypeOf)

26import GHCJS.Foreign (JSType(..), jsTypeOf)

28−import GHCJS.Types

29−import JavaScript.TypedArray.ArrayBuffer as JS

30import Language.Javascript.JSaddle.Helper (mutableArrayBufferFromJSVal)

27import Language.Javascript.JSaddle.Helper (mutableArrayBufferFromJSVal)

31import Language.Javascript.JSaddle.Types (ghcjsPure)

28import Language.Javascript.JSaddle.Types (ghcjsPure)

32−#ifndef ghcjs_HOST_OS

33−import Language.Javascript.JSaddle.Object (new, jsg)

34−#endif

36data JSWebSocket = JSWebSocket { unWebSocket :: WebSocket }

30data JSWebSocket = JSWebSocket { unWebSocket :: WebSocket }

@@ -42,12 +36,7 @@ class IsWebSocketMessage a where

42-- Note: Binary websockets may not work correctly in IE 11 and below

36-- Note: Binary websockets may not work correctly in IE 11 and below

43instance IsWebSocketMessage ByteString where

37instance IsWebSocketMessage ByteString where

44 webSocketSend (JSWebSocket ws) bs = do

38 webSocketSend (JSWebSocket ws) bs = do

45− (b, off, len) <- ghcjsPure $ fromByteString bs

39+ ab <- bsToArrayBuffer 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 create 0 >>= ghcjsPure . getArrayBuffer >>= ghcjsPure . jsval

48− else do

49− ref <- ghcjsPure (getArrayBuffer b) >>= ghcjsPure . jsval

50− js_dataView off len ref -- new (jsg "DataView") (ref, off, len)

51 GD.send ws $ Just ab

40 GD.send ws $ Just ab

53-- Use plaintext websocket communication for Text, and String

42-- Use plaintext websocket communication for Text, and String

@@ -82,16 +71,9 @@ newWebSocket _ url onMessage onOpen onError onClose = do

82 liftJSM $ ghcjsPure (jsTypeOf d) >>= \case

71 liftJSM $ ghcjsPure (jsTypeOf d) >>= \case

83 String -> onMessage $ Right d

72 String -> onMessage $ Right d

84 _ -> do

73 _ -> do

85− ab <- mutableArrayBufferFromJSVal d >>= unsafeFreeze

74+ ab <- mutableArrayBufferFromJSVal d

86− ghcjsPure (createFromArrayBuffer ab) >>= ghcjsPure . toByteString 0 Nothing >>= onMessage . Left

75+ bsFromMutableArrayBuffer ab >>= onMessage . Left

87 return $ JSWebSocket ws

76 return $ JSWebSocket ws

89−#ifdef ghcjs_HOST_OS

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

91−#else

92−js_dataView :: Int -> Int -> JSVal -> JSM JSVal

93−js_dataView off len ref = new (jsg "DataView") (ref, off, len)

94−#endif

95−

96onBSMessage :: Either ByteString JSVal -> JSM ByteString

78onBSMessage :: Either ByteString JSVal -> JSM ByteString

97onBSMessage = either return (\v -> encodeUtf8 <$> fromJSValUnchecked v)

79onBSMessage = either return (\v -> encodeUtf8 <$> fromJSValUnchecked v)

reflex-dom-core/src/Reflex/Dom/Widget/Basic.hs+7−3

@@ -144,6 +144,7 @@ dynText t = do

144 [ updated t

145 , tag (current t) postBuild

146 ]

147+ notReadyUntil postBuild

147

148

148display :: (PostBuild t m, DomBuilder t m, Show a) => Dynamic t a -> m ()

149display :: (PostBuild t m, DomBuilder t m, Show a) => Dynamic t a -> m ()

149display = dynText . fmap (T.pack . show)

150display = dynText . fmap (T.pack . show)

@@ -161,7 +162,7 @@ dyn :: (DomBuilder t m, PostBuild t m) => Dynamic t (m a) -> m (Event t a)

161dyn child = do

162dyn child = do

162 postBuild <- getPostBuild

163 postBuild <- getPostBuild

163 let newChild = leftmost [updated child, tagCheap (current child) postBuild]

164 let newChild = leftmost [updated child, tagCheap (current child) postBuild]

164− snd <$> widgetHoldInternal (return ()) newChild

165+ snd <$> widgetHoldInternal notReady newChild

165

166

166-- | Given an initial widget and an Event of widget-creating actions, create a widget that is recreated whenever the Event fires.

167-- | Given an initial widget and an Event of widget-creating actions, create a widget that is recreated whenever the Event fires.

167-- The returned Dynamic of widget results occurs when the Event does.

168-- The returned Dynamic of widget results occurs when the Event does.

@@ -341,8 +342,11 @@ elDynAttrNS' mns elementTag attrs child = do

341 modifyAttrs <- dynamicAttributesToModifyAttributes attrs

342 modifyAttrs <- dynamicAttributesToModifyAttributes attrs

342 let cfg = def

343 let cfg = def

343 & elementConfig_namespace .~ mns

344 & elementConfig_namespace .~ mns

344− & modifyAttributes .~ fmap mapKeysToAttributeName modifyAttrs

345+ & modifyAttributes .~ fmapCheap mapKeysToAttributeName modifyAttrs

345− element elementTag cfg child

346+ result <- element elementTag cfg child

347+ postBuild <- getPostBuild

348+ notReadyUntil postBuild

349+ return result

346

350

347dynamicAttributesToModifyAttributes :: (Ord k, PostBuild t m) => Dynamic t (Map k Text) -> m (Event t (Map k (Maybe Text)))

351dynamicAttributesToModifyAttributes :: (Ord k, PostBuild t m) => Dynamic t (Map k Text) -> m (Event t (Map k (Maybe Text)))

348dynamicAttributesToModifyAttributes = dynamicAttributesToModifyAttributesWithInitial mempty

352dynamicAttributesToModifyAttributes = dynamicAttributesToModifyAttributesWithInitial mempty

reflex-dom-core/src/Reflex/Dom/Xhr/Foreign.hs+12−12

@@ -15,21 +15,17 @@ import Control.Monad.IO.Class (MonadIO(..))

15import Data.Maybe (fromMaybe)

16import Data.Text (Text)

17import Data.ByteString (ByteString)

18+import Foreign.JavaScript.Utils (bsFromMutableArrayBuffer, bsToArrayBuffer)

18import GHCJS.DOM.Enums

19import GHCJS.DOM.Enums

19import GHCJS.DOM.EventM (EventM, on)

20import GHCJS.DOM.EventM (EventM, on)

20import GHCJS.DOM.EventTarget (dispatchEvent)

21import GHCJS.DOM.EventTarget (dispatchEvent)

21import GHCJS.DOM.Types hiding (Text)

22import GHCJS.DOM.Types hiding (Text)

22import GHCJS.DOM.XMLHttpRequest

23import GHCJS.DOM.XMLHttpRequest

23−-- import GHCJS.Types

24+import Language.Javascript.JSaddle.Helper (mutableArrayBufferFromJSVal)

25+import qualified Language.Javascript.JSaddle.Monad as JS (catch)

24import Prelude hiding (error)

26import Prelude hiding (error)

25import Reflex.Dom.Xhr.Exception

27import Reflex.Dom.Xhr.Exception

26import Reflex.Dom.Xhr.ResponseType

28import Reflex.Dom.Xhr.ResponseType

27−import Language.Javascript.JSaddle.Types (ghcjsPure)

28−import qualified Language.Javascript.JSaddle.Monad as JS (catch)

29−import qualified GHCJS.Buffer as JS

30− (createFromArrayBuffer, toByteString)

31−import qualified JavaScript.TypedArray.ArrayBuffer as JS

32− (unsafeFreeze, MutableArrayBuffer)

34xmlHttpRequestNew :: MonadJSM m => m XMLHttpRequest

30xmlHttpRequestNew :: MonadJSM m => m XMLHttpRequest

35xmlHttpRequestNew = newXMLHttpRequest

31xmlHttpRequestNew = newXMLHttpRequest

@@ -65,6 +61,12 @@ instance IsXhrPayload Document where

65instance IsXhrPayload Blob where

61instance IsXhrPayload Blob where

66 sendXhrPayload = sendBlob

62 sendXhrPayload = sendBlob

64+instance IsXhrPayload ArrayBuffer where

65+ sendXhrPayload xhr ab = sendArrayBuffer xhr (ArrayBufferView $ unArrayBuffer ab)

66+

67+instance IsXhrPayload ByteString where

68+ sendXhrPayload xhr bs = sendXhrPayload xhr =<< liftJSM (bsToArrayBuffer bs)

69+

68newtype XhrPayload = XhrPayload { unXhrPayload :: JSVal }

70newtype XhrPayload = XhrPayload { unXhrPayload :: JSVal }

70-- This used to be a non blocking call, but now it uses an interruptible ffi

72-- This used to be a non blocking call, but now it uses an interruptible ffi

@@ -178,9 +180,7 @@ xmlHttpRequestGetResponse xhr = do

178 Just XhrResponseType_Default -> Just . XhrResponseBody_Text <$> xmlHttpRequestGetStatusText xhr

180 Just XhrResponseType_Default -> Just . XhrResponseBody_Text <$> xmlHttpRequestGetStatusText xhr

179 Just XhrResponseType_ArrayBuffer -> case fmap unGObject mr of

181 Just XhrResponseType_ArrayBuffer -> case fmap unGObject mr of

180 Nothing -> return Nothing

182 Nothing -> return Nothing

183+ Just ptr -> do

184+ ab <- liftJSM $ mutableArrayBufferFromJSVal ptr

181− Just ptr -> Just . XhrResponseBody_ArrayBuffer <$> bsFromArrayBuffer (pFromJSVal ptr)

185+ Just . XhrResponseBody_ArrayBuffer <$> bsFromMutableArrayBuffer ab

182 _ -> return Nothing

186 _ -> return Nothing

183−

184−bsFromArrayBuffer :: MonadJSM m => JS.MutableArrayBuffer -> m ByteString

185−bsFromArrayBuffer ab = liftJSM $ JS.unsafeFreeze ab >>=

186− ghcjsPure . JS.createFromArrayBuffer >>= ghcjsPure . JS.toByteString 0 Nothing

test/prebuild.hsnew file+107

@@ -0,0 +1,107 @@

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE OverloadedStrings #-}

3+{-# LANGUAGE ScopedTypeVariables #-}

4+{-# LANGUAGE TypeFamilies #-}

5+{-# LANGUAGE LambdaCase #-}

6+{-# LANGUAGE FlexibleInstances #-}

7+{-# LANGUAGE MultiParamTypeClasses #-}

8+import Control.Monad

9+import Control.Monad.Trans

10+import Reflex.Dom

11+import qualified Data.Text as T

12+import Control.Concurrent

13+

14+import Control.Monad.State.Strict

15+import Data.Functor.Misc

16+import Data.Monoid

17+import Data.Word

18+import qualified Data.Map as Map

19+import qualified Data.Dependent.Map as DMap

20+import Data.Dependent.Sum

21+import qualified Reflex.Patch.DMapWithMove as PatchDMapWithMove

22+

23+main :: IO ()

24+main = mainWidget w

25+

26+w :: forall t m. (MonadWidget t m, MountableDomBuilder t m) => m ()

27+w = do

28+ let slow :: forall m'. MonadWidget t m' => m' ()

29+ {-

30+ performEventChain = do

31+ postBuild <- delay 0 =<< getPostBuild

32+ rec let maxN = 10000

33+ n = leftmost [0 <$ postBuild, ffilter (<=maxN) $ succ <$> n']

34+ n' <- performEvent $ return <$> n

35+ pausedUntil $ ffilter (==maxN) n'

36+ _ <- widgetHold (text "Starting") $ text . T.pack . show <$> n

37+ return ()

38+ -}

39+ {- Many dyns

40+ slow = elAttr "div" ("style" =: "position:relative;width:256px;height:256px") $ go maxDepth

41+ where maxDepth = 6 :: Int

42+ go 0 = blank

43+ go n = void $ dyn $ pure $ do

44+ let bgcolor = "rgba(0,0,0," <> T.pack (show (1 - (fromIntegral n / fromIntegral maxDepth) :: Double)) <> ")"

45+ s pos = pos <> ";position:absolute;border:1px solid white;background-color:" <> bgcolor

46+ elAttr "div" ("style" =: s "left:0;right:50%;top:0;bottom:50%") $ go $ pred n

47+ elAttr "div" ("style" =: s "left:50%;right:0;top:0;bottom:50%") $ go $ pred n

48+ elAttr "div" ("style" =: s "left:50%;right:0;top:50%;bottom:0") $ go $ pred n

49+ elAttr "div" ("style" =: s "left:0;right:50%;top:50%;bottom:0") $ go $ pred n

50+ -}

51+ {- Many elDynAttrs

52+ slow = do

53+ let size = 64

54+ replicateM_ size $ elAttr "div" ("style" =: ("height:4px;width:" <> T.pack (show (size*4)) <> "px;line-height:0;background-color:gray")) $ do

55+ replicateM_ size $ elDynAttr "div" (pure $ "style" =: "display:inline-block;width:4px;height:4px;background-color:black") blank

56+ -}

57+ {- Many dynTexts

58+ slow = el "table" $ do

59+ let size = 64

60+ replicateM_ size $ el "tr" $ do

61+ replicateM_ size $ el "td" $ do

62+ dynText $ pure "."

63+ -}

64+ {- Many simultaneous performEvents

65+ slow = do

66+ postBuild <- getPostBuild

67+ replicateM_ ((2 :: Int) ^ (14 :: Int)) $ performEvent_ $ return () <$ postBuild

68+ done <- performEvent $ return () <$ postBuild

69+ _ <- widgetHold (text "Doing performEvent") $ text "Done" <$ done

70+ return ()

71+ -}

72+ {-

73+ slow = do

74+ postBuild <- getPostBuild

75+ postBuild' <- performEvent . (return () <$) =<< performEvent . (return () <$) =<< getPostBuild

76+ let f x = Map.fromList [(n, x) | n <- [1 :: Int .. 4096]]

77+ listHoldWithKey (f False) (f (Just True) <$ postBuild') $ \k -> \case

78+ False -> do

79+ text "X "

80+ notReadyUntil =<< getPostBuild

81+ True -> do

82+ text ". "

83+ return ()

84+ -}

85+ slow = do

86+ let f :: forall a. EitherTag () () a -> Const2 () () a -> m' (Const2 () () a)

87+ f _ (Const2 ()) = do

88+ notReadyUntil =<< delay 0.5 =<< getPostBuild

89+ text "Done"

90+ return $ Const2 ()

91+ postBuild <- getPostBuild

92+ traverseDMapWithKeyWithAdjustWithMove f (DMap.singleton LeftTag $ Const2 ()) $ (PatchDMapWithMove.moveDMapKey LeftTag RightTag) <$ postBuild

93+ return ()

94+ el "div" $ do

95+ draw <- button "Draw"

96+ widgetHold blank $ ffor draw $ \_ -> do

97+ postBuild <- getPostBuild

98+ widgetHold (text "Loading...") $ slow <$ postBuild

99+ return ()

100+ return ()

101+

102+#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES

103+instance {-# INCOHERENT #-} (Show (f a), Show (f b)) => ShowTag (EitherTag a b) f where

104+ showTagToShow e _ = case e of

105+ LeftTag -> id

106+ RightTag -> id

107+#endif