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

git.iko.soy/reflex-dom

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

commit5d9433ca36eaf31ab35e9050d0db5c7a2bdc7783 authorWill Fancher <elvishjerricco@gmail.com> dateWed 26 Apr 2017, 11:46 (10 years ago) parent4026f78 b3d612e

14 files changed+607−213

compare with develop

unifiedsplit

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

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

1111Build-type: Simple

1212Cabal-version: >=1.9.2

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

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

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

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

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

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

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

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

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

8688 exposed-modules:

8789 Foreign.JavaScript.TH

8890 Foreign.JavaScript.Orphans

91+ Foreign.JavaScript.Utils

8992 Reflex.Dom.Builder.Class

9093 Reflex.Dom.Builder.Class.Events

9194 Reflex.Dom.Builder.Immediate

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

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

11module Foreign.JavaScript.Internal.Utils

22 ( synchronously

33 , freeRequestAnimationFrameCallback

4+ , js_dataView

45 ) where

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

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

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

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

910synchronously :: JSM a -> JSM a

1011synchronously = id

1112

1213freeRequestAnimationFrameCallback :: RequestAnimationFrameCallback -> JSM ()

1314freeRequestAnimationFrameCallback (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 #-}

14module Foreign.JavaScript.Internal.Utils

25 ( synchronously

36 , freeRequestAnimationFrameCallback

7+ , js_dataView

48 ) where

610import GHCJS.Concurrent

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

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

812import GHCJS.Foreign.Callback (releaseCallback)

913

1014freeRequestAnimationFrameCallback :: RequestAnimationFrameCallback -> JSM ()

1115freeRequestAnimationFrameCallback (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

178178 restoreT = defaultRestoreT WithJSContextSingleton

179179

180180instance 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?

182182 {-# INLINABLE performEvent_ #-}

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

184184 {-# 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

149149 { _rawElementConfig_eventSpec = _rawElementConfig_eventSpec cfg

150150 }

151151 {-# 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 ()

152171

153172type Namespace = Text

154173

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

512531 type DomBuilderSpace (PostBuildT t m) = DomBuilderSpace m

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

514533

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+

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

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

517541 textNode = liftTextNode

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

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

1414#else

1515import Data.GADT.Compare

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

17−import Control.Monad (ap)

1817#endif

1918

2019data EventTag

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

238237 geq Touchcancel Touchcancel = return Refl

239238 geq _ _ = Nothing

240239

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−

254240instance GCompare EventName

255− where gcompare Abort Abort = runGComparing $ return GEQ

241+ where gcompare Abort Abort = GEQ

256242 gcompare Abort _ = GLT

257243 gcompare _ Abort = GGT

258− gcompare Blur Blur = runGComparing $ return GEQ

244+ gcompare Blur Blur = GEQ

259245 gcompare Blur _ = GLT

260246 gcompare _ Blur = GGT

261− gcompare Change Change = runGComparing $ return GEQ

247+ gcompare Change Change = GEQ

262248 gcompare Change _ = GLT

263249 gcompare _ Change = GGT

264− gcompare Click Click = runGComparing $ return GEQ

250+ gcompare Click Click = GEQ

265251 gcompare Click _ = GLT

266252 gcompare _ Click = GGT

267− gcompare Contextmenu Contextmenu = runGComparing $ return GEQ

253+ gcompare Contextmenu Contextmenu = GEQ

268254 gcompare Contextmenu _ = GLT

269255 gcompare _ Contextmenu = GGT

270− gcompare Dblclick Dblclick = runGComparing $ return GEQ

256+ gcompare Dblclick Dblclick = GEQ

271257 gcompare Dblclick _ = GLT

272258 gcompare _ Dblclick = GGT

273− gcompare Drag Drag = runGComparing $ return GEQ

259+ gcompare Drag Drag = GEQ

274260 gcompare Drag _ = GLT

275261 gcompare _ Drag = GGT

276− gcompare Dragend Dragend = runGComparing $ return GEQ

262+ gcompare Dragend Dragend = GEQ

277263 gcompare Dragend _ = GLT

278264 gcompare _ Dragend = GGT

279− gcompare Dragenter Dragenter = runGComparing $ return GEQ

265+ gcompare Dragenter Dragenter = GEQ

280266 gcompare Dragenter _ = GLT

281267 gcompare _ Dragenter = GGT

282− gcompare Dragleave Dragleave = runGComparing $ return GEQ

268+ gcompare Dragleave Dragleave = GEQ

283269 gcompare Dragleave _ = GLT

284270 gcompare _ Dragleave = GGT

285− gcompare Dragover Dragover = runGComparing $ return GEQ

271+ gcompare Dragover Dragover = GEQ

286272 gcompare Dragover _ = GLT

287273 gcompare _ Dragover = GGT

288− gcompare Dragstart Dragstart = runGComparing $ return GEQ

274+ gcompare Dragstart Dragstart = GEQ

289275 gcompare Dragstart _ = GLT

290276 gcompare _ Dragstart = GGT

291− gcompare Drop Drop = runGComparing $ return GEQ

277+ gcompare Drop Drop = GEQ

292278 gcompare Drop _ = GLT

293279 gcompare _ Drop = GGT

294− gcompare Error Error = runGComparing $ return GEQ

280+ gcompare Error Error = GEQ

295281 gcompare Error _ = GLT

296282 gcompare _ Error = GGT

297− gcompare Focus Focus = runGComparing $ return GEQ

283+ gcompare Focus Focus = GEQ

298284 gcompare Focus _ = GLT

299285 gcompare _ Focus = GGT

300− gcompare Input Input = runGComparing $ return GEQ

286+ gcompare Input Input = GEQ

301287 gcompare Input _ = GLT

302288 gcompare _ Input = GGT

303− gcompare Invalid Invalid = runGComparing $ return GEQ

289+ gcompare Invalid Invalid = GEQ

304290 gcompare Invalid _ = GLT

305291 gcompare _ Invalid = GGT

306− gcompare Keydown Keydown = runGComparing $ return GEQ

292+ gcompare Keydown Keydown = GEQ

307293 gcompare Keydown _ = GLT

308294 gcompare _ Keydown = GGT

309− gcompare Keypress Keypress = runGComparing $ return GEQ

295+ gcompare Keypress Keypress = GEQ

310296 gcompare Keypress _ = GLT

311297 gcompare _ Keypress = GGT

312− gcompare Keyup Keyup = runGComparing $ return GEQ

298+ gcompare Keyup Keyup = GEQ

313299 gcompare Keyup _ = GLT

314300 gcompare _ Keyup = GGT

315− gcompare Load Load = runGComparing $ return GEQ

301+ gcompare Load Load = GEQ

316302 gcompare Load _ = GLT

317303 gcompare _ Load = GGT

318− gcompare Mousedown Mousedown = runGComparing $ return GEQ

304+ gcompare Mousedown Mousedown = GEQ

319305 gcompare Mousedown _ = GLT

320306 gcompare _ Mousedown = GGT

321− gcompare Mouseenter Mouseenter = runGComparing $ return GEQ

307+ gcompare Mouseenter Mouseenter = GEQ

322308 gcompare Mouseenter _ = GLT

323309 gcompare _ Mouseenter = GGT

324− gcompare Mouseleave Mouseleave = runGComparing $ return GEQ

310+ gcompare Mouseleave Mouseleave = GEQ

325311 gcompare Mouseleave _ = GLT

326312 gcompare _ Mouseleave = GGT

327− gcompare Mousemove Mousemove = runGComparing $ return GEQ

313+ gcompare Mousemove Mousemove = GEQ

328314 gcompare Mousemove _ = GLT

329315 gcompare _ Mousemove = GGT

330− gcompare Mouseout Mouseout = runGComparing $ return GEQ

316+ gcompare Mouseout Mouseout = GEQ

331317 gcompare Mouseout _ = GLT

332318 gcompare _ Mouseout = GGT

333− gcompare Mouseover Mouseover = runGComparing $ return GEQ

319+ gcompare Mouseover Mouseover = GEQ

334320 gcompare Mouseover _ = GLT

335321 gcompare _ Mouseover = GGT

336− gcompare Mouseup Mouseup = runGComparing $ return GEQ

322+ gcompare Mouseup Mouseup = GEQ

337323 gcompare Mouseup _ = GLT

338324 gcompare _ Mouseup = GGT

339− gcompare Mousewheel Mousewheel = runGComparing $ return GEQ

325+ gcompare Mousewheel Mousewheel = GEQ

340326 gcompare Mousewheel _ = GLT

341327 gcompare _ Mousewheel = GGT

342− gcompare Scroll Scroll = runGComparing $ return GEQ

328+ gcompare Scroll Scroll = GEQ

343329 gcompare Scroll _ = GLT

344330 gcompare _ Scroll = GGT

345− gcompare Select Select = runGComparing $ return GEQ

331+ gcompare Select Select = GEQ

346332 gcompare Select _ = GLT

347333 gcompare _ Select = GGT

348− gcompare Submit Submit = runGComparing $ return GEQ

334+ gcompare Submit Submit = GEQ

349335 gcompare Submit _ = GLT

350336 gcompare _ Submit = GGT

351− gcompare Wheel Wheel = runGComparing $ return GEQ

337+ gcompare Wheel Wheel = GEQ

352338 gcompare Wheel _ = GLT

353339 gcompare _ Wheel = GGT

354− gcompare Beforecut Beforecut = runGComparing $ return GEQ

340+ gcompare Beforecut Beforecut = GEQ

355341 gcompare Beforecut _ = GLT

356342 gcompare _ Beforecut = GGT

357− gcompare Cut Cut = runGComparing $ return GEQ

343+ gcompare Cut Cut = GEQ

358344 gcompare Cut _ = GLT

359345 gcompare _ Cut = GGT

360− gcompare Beforecopy Beforecopy = runGComparing $ return GEQ

346+ gcompare Beforecopy Beforecopy = GEQ

361347 gcompare Beforecopy _ = GLT

362348 gcompare _ Beforecopy = GGT

363− gcompare Copy Copy = runGComparing $ return GEQ

349+ gcompare Copy Copy = GEQ

364350 gcompare Copy _ = GLT

365351 gcompare _ Copy = GGT

366− gcompare Beforepaste Beforepaste = runGComparing $ return GEQ

352+ gcompare Beforepaste Beforepaste = GEQ

367353 gcompare Beforepaste _ = GLT

368354 gcompare _ Beforepaste = GGT

369− gcompare Paste Paste = runGComparing $ return GEQ

355+ gcompare Paste Paste = GEQ

370356 gcompare Paste _ = GLT

371357 gcompare _ Paste = GGT

372− gcompare Reset Reset = runGComparing $ return GEQ

358+ gcompare Reset Reset = GEQ

373359 gcompare Reset _ = GLT

374360 gcompare _ Reset = GGT

375− gcompare Search Search = runGComparing $ return GEQ

361+ gcompare Search Search = GEQ

376362 gcompare Search _ = GLT

377363 gcompare _ Search = GGT

378− gcompare Selectstart Selectstart = runGComparing $ return GEQ

364+ gcompare Selectstart Selectstart = GEQ

379365 gcompare Selectstart _ = GLT

380366 gcompare _ Selectstart = GGT

381− gcompare Touchstart Touchstart = runGComparing $ return GEQ

367+ gcompare Touchstart Touchstart = GEQ

382368 gcompare Touchstart _ = GLT

383369 gcompare _ Touchstart = GGT

384− gcompare Touchmove Touchmove = runGComparing $ return GEQ

370+ gcompare Touchmove Touchmove = GEQ

385371 gcompare Touchmove _ = GLT

386372 gcompare _ Touchmove = GGT

387− gcompare Touchend Touchend = runGComparing $ return GEQ

373+ gcompare Touchend Touchend = GEQ

388374 gcompare Touchend _ = GLT

389375 gcompare _ Touchend = GGT

390− gcompare Touchcancel Touchcancel = runGComparing $ return GEQ

391− gcompare Touchcancel _ = GLT

392− gcompare _ Touchcancel = GGT

376+ gcompare Touchcancel Touchcancel = GEQ

393377#endif

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

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

55{-# LANGUAGE EmptyDataDecls #-}

66{-# LANGUAGE FlexibleContexts #-}

77{-# LANGUAGE FlexibleInstances #-}

8+{-# LANGUAGE GADTs #-}

89{-# LANGUAGE GeneralizedNewtypeDeriving #-}

910{-# LANGUAGE LambdaCase #-}

1011{-# LANGUAGE MultiParamTypeClasses #-}

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

4849 , Pair1 (..)

4950 , Maybe1 (..)

5051 , GhcjsEventSpec (..)

52+ , ghcjsEventSpec_filters

53+ , ghcjsEventSpec_handler

5154 , GhcjsEventHandler (..)

5255#ifndef USE_TEMPLATE_HASKELL

5356 , phantom2

54− , ghcjsEventSpec_filters

55− , ghcjsEventSpec_handler

5657#endif

5758 , drawChildUpdate

5859 , mkHasFocus

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

7475 , WindowConfig (..)

7576 , Window (..)

7677 , wrapWindow

77− , ghcjsEventSpec_filters

78− , ghcjsEventSpec_handler

7978 ) where

8079

8180import Foreign.JavaScript.TH

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

8382import Reflex.Dom.Builder.Class

8483import Reflex.Dynamic

8584import Reflex.Host.Class

85+import qualified Reflex.Patch.DMap as PatchDMap

86+import qualified Reflex.Patch.DMapWithMove as PatchDMapWithMove

8687import Reflex.PerformEvent.Class

8788import Reflex.PostBuild.Class

8889import Reflex.TriggerEvent.Base hiding (askEvents)

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

106107import Data.Functor.Compose

107108import Data.Functor.Constant

108109import Data.Functor.Misc

110+import Data.Functor.Product

109111import Data.IORef

110112import qualified Data.Map as Map

111113import Data.Maybe

112−import Data.Monoid

114+import Data.Monoid hiding (Product)

115+import Data.Some (Some)

113116import qualified Data.Some as Some

114117import Data.Text (Text)

115118import qualified Data.Text as T

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

144147import Reflex.Requester.Class

145148import Foreign.JavaScript.Internal.Utils

146149

147−data ImmediateDomBuilderEnv t m

150+data ImmediateDomBuilderEnv t

148151 = ImmediateDomBuilderEnv { _immediateDomBuilderEnv_document :: Document

149152 , _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

150155 }

151156

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 }

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

154159

155160#ifndef __GHCJS__

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

164169instance MonadTrans (ImmediateDomBuilderT t) where

165170 lift = ImmediateDomBuilderT . lift . lift . lift

166171

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

168173 withRenderHook hook (ImmediateDomBuilderT a) = do

169174 e <- ImmediateDomBuilderT ask

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

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

185190 , Ref m ~ IORef

186191 )

187192 => ImmediateDomBuilderT t m a

188− -> ImmediateDomBuilderEnv t m

193+ -> ImmediateDomBuilderEnv t

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

190195 -> m a

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

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

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

216221askEvents = ImmediateDomBuilderT . lift . lift $ TriggerEventT.askEvents

217222

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

224+localEnv f = ImmediateDomBuilderT . local f . unImmediateDomBuilderT

225+

218226{-# INLINABLE append #-}

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

220228append n = do

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

278286 ]

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

280288

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)

282290

283291{-# INLINABLE collectUpTo #-}

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

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

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

300308wrap e cfg = do

301309 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

303311 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

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

306314 triggerRef <- liftIO $ newIORef Nothing

307315 _ <- elementOnEventName en e $ do

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

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

335343 ref <- newIORef $ Just t

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

337− return $ Element es e

345+ return $ Element

346+ { _element_events = es

347+ , _element_raw = e

348+ }

338349

339350{-# INLINABLE makeElement #-}

340351makeElement :: 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)

341352makeElement elementTag cfg child = do

342353 doc <- askDocument

343− env <- ImmediateDomBuilderT ask

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

345355 Nothing -> createElementUnchecked doc (Just elementTag)

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

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

348358 Nothing -> lift $ setAttribute e n v

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

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

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

351361 { _immediateDomBuilderEnv_parent = toNode e

352362 }

353363 append e

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

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

436446 v0 <- Input.getValueUnchecked domInputElement

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

439449 valueChangedBySetValue <- case _inputElementConfig_setValue cfg of

440450 Nothing -> return never

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

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

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

487497 v0 <- TextArea.getValueUnchecked domTextAreaElement

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

490500 valueChangedBySetValue <- case _textAreaElementConfig_setValue cfg of

491501 Nothing -> return never

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

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

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

512522 Just v0 <- Select.getValue domSelectElement

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

515525 valueChangedBySetValue <- case _selectElementConfig_setValue cfg of

516526 Nothing -> return never

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

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

532542 return (wrapped, result)

533543 placeRawElement = append

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

535569

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

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+

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

537603 runWithReplace a0 a' = do

538604 initialEnv <- ImmediateDomBuilderT ask

539605 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

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

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

619+ doc <- askDocument

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

542621 let drawInitialChild = do

543− result <- a0

544− append after

622+ unreadyChildren <- liftIO $ newIORef 0

623+ let f = do

624+ result <- a0

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

545634 return result

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

547− df <- createDocumentFragmentUnchecked $ _immediateDomBuilderEnv_document initialEnv

635+ a'' <- numberOccurrences a'

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

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

548646 result <- runReaderT (unImmediateDomBuilderT child) $ initialEnv

549647 { _immediateDomBuilderEnv_parent = toNode df

648+ , _immediateDomBuilderEnv_unreadyChildren = unreadyChildren

649+ , _immediateDomBuilderEnv_commitAction = commitAction

550650 }

551− let update = do

552− deleteBetweenExclusive before after

553− insertBefore df after

554− return (result, update)

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

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

652+ 0 -> liftJSM commitAction

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

654+ return result

576655 return (result0, result')

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

578− initialEnv <- ImmediateDomBuilderT ask

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

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

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

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

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

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

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

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

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

656+ traverseDMapWithKeyWithAdjust = do

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

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)

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

660+ Nothing -> return Nothing

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

662+ readIORef sRef >>= \case

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

664+ ChildReadyState_Unready _ -> do

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

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

588701 let p = unPatchDMapWithMove p_

589− phsBefore <- sample placeholders

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

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

592− collectIfMoved k e = do

593− 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

595− case dmapEditMoved e of

596− False -> do

597− mapM_ (`deleteUpTo` nextPlaceholder) mThisPlaceholder

598− return $ Constant Nothing

599− True -> do

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

601− collected <- DMap.traverseWithKey collectIfMoved p

602− 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)

604− placeFragment k e = do

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

606− case e of

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

608− df `insertBefore` nextPlaceholder

609− DMapEdit_Delete _ -> do

610− return ()

611− DMapEdit_Move _ fromKey -> do

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

613− mapM_ (`insertBefore` nextPlaceholder) mdf

614− 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

616− return ()

617− return (result0, result')

618−

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)

620−drawChildUpdate initialEnv child = do

702+ phsBefore <- liftIO $ readIORef placeholders

703+ lastPlaceholder <- liftIO $ readIORef lastPlaceholderRef

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)

705+ collectIfMoved k e = do

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

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

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

709+ False -> do

710+ mapM_ (`deleteUpTo` nextPlaceholder) mThisPlaceholder

711+ return $ Constant Nothing

712+ True -> do

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

714+ collected <- DMap.traverseWithKey collectIfMoved p

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

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

717+ placeFragment k e = do

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

719+ case PatchDMapWithMove._nodeInfo_from e of

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

721+ df `insertBefore` nextPlaceholder

722+ PatchDMapWithMove.From_Delete -> do

723+ return ()

724+ PatchDMapWithMove.From_Move fromKey -> do

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

726+ mapM_ (`insertBefore` nextPlaceholder) mdf

727+ return $ Constant ()

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

729+ liftIO $ writeIORef placeholders $! phsAfter

730+

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)

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

831+drawChildUpdate initialEnv markReady child = do

832+ childReadyState <- liftIO $ newIORef $ ChildReadyState_Unready Nothing

833+ unreadyChildren <- liftIO $ newIORef 0

621834 df <- createDocumentFragmentUnchecked $ _immediateDomBuilderEnv_document initialEnv

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

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

623836 { _immediateDomBuilderEnv_parent = toNode df

837+ , _immediateDomBuilderEnv_unreadyChildren = unreadyChildren

838+ , _immediateDomBuilderEnv_commitAction = markReady childReadyState

624839 }

840+ u <- liftIO $ readIORef unreadyChildren

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

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

625843

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

627845mkHasFocus 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

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

151151 StaticDomBuilderT $ modify $ (:) $ join o

152152 return (fst result0, fmapCheap fst result')

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

154− e <- StaticDomBuilderT ask

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

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

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

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

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

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

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

162− outputs <- holdIncremental outputs0 outputs'

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

164− os <- sample $ currentIncremental outputs

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

166− sample o

167− return (result0, result')

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

176+ e <- StaticDomBuilderT ask

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

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

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

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

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

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

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

184+ outputs <- holdIncremental outputs0 outputs'

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

186+ os <- sample $ currentIncremental outputs

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

188+ sample o

189+ return (result0, result')

168190

169191-- 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.

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

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

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

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

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

208234 {-# INLINABLE inputElement #-}

209235 inputElement cfg = do

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

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

250276 return (wrapped, result)

251277 placeRawElement () = return ()

252278 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?

253281

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

255283type 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

9090 (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef

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

9292 go w df = do

93+ unreadyChildren <- liftIO $ newIORef 0

9394 let builderEnv = ImmediateDomBuilderEnv

9495 { _immediateDomBuilderEnv_document = toDocument doc

9596 , _immediateDomBuilderEnv_parent = toNode df

97+ , _immediateDomBuilderEnv_unreadyChildren = unreadyChildren

98+ , _immediateDomBuilderEnv_commitAction = return () --TODO

9699 }

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

98101 rec b <- go (headWidget a) headFragment

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

115118 df <- createDocumentFragmentUnchecked doc

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

117120 (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef

121+ unreadyChildren <- liftIO $ newIORef 0

118122 let builderEnv = ImmediateDomBuilderEnv

119123 { _immediateDomBuilderEnv_document = toDocument doc

120124 , _immediateDomBuilderEnv_parent = toNode df

125+ , _immediateDomBuilderEnv_unreadyChildren = unreadyChildren

126+ , _immediateDomBuilderEnv_commitAction = return () --TODO

121127 }

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

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

1414

1515import Control.Monad.Reader

1616import Data.ByteString (ByteString)

17−import qualified Data.ByteString as BS

1817import Data.Text (Text)

1918import qualified Data.Text as T (unpack)

2019import Data.Text.Encoding

21−import GHCJS.Buffer

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

2221import GHCJS.DOM.CloseEvent

2322import GHCJS.DOM.EventM (on)

2423import GHCJS.DOM.MessageEvent

2524import GHCJS.DOM.Types hiding (Text)

2625import qualified GHCJS.DOM.WebSocket as GD

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

28−import GHCJS.Types

29−import JavaScript.TypedArray.ArrayBuffer as JS

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

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

32−#ifndef ghcjs_HOST_OS

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

34−#endif

3529

3630data JSWebSocket = JSWebSocket { unWebSocket :: WebSocket }

3731

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

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

4337instance IsWebSocketMessage ByteString where

4438 webSocketSend (JSWebSocket ws) bs = do

45− (b, off, len) <- ghcjsPure $ 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 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)

39+ ab <- bsToArrayBuffer bs

5140 GD.send ws $ Just ab

5241

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

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

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

8372 String -> onMessage $ Right d

8473 _ -> do

85− ab <- mutableArrayBufferFromJSVal d >>= unsafeFreeze

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

74+ ab <- mutableArrayBufferFromJSVal d

75+ bsFromMutableArrayBuffer ab >>= onMessage . Left

8776 return $ JSWebSocket ws

8877

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−

9678onBSMessage :: Either ByteString JSVal -> JSM ByteString

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

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

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

144144 [ updated t

145145 , tag (current t) postBuild

146146 ]

147+ notReadyUntil postBuild

147148

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

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

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

161162dyn child = do

162163 postBuild <- getPostBuild

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

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

165+ snd <$> widgetHoldInternal notReady newChild

165166

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

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

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

341342 modifyAttrs <- dynamicAttributesToModifyAttributes attrs

342343 let cfg = def

343344 & elementConfig_namespace .~ mns

344− & modifyAttributes .~ fmap mapKeysToAttributeName modifyAttrs

345− element elementTag cfg child

345+ & modifyAttributes .~ fmapCheap mapKeysToAttributeName modifyAttrs

346+ result <- element elementTag cfg child

347+ postBuild <- getPostBuild

348+ notReadyUntil postBuild

349+ return result

346350

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

348352dynamicAttributesToModifyAttributes = dynamicAttributesToModifyAttributesWithInitial mempty

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

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

1515import Data.Maybe (fromMaybe)

1616import Data.Text (Text)

1717import Data.ByteString (ByteString)

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

1819import GHCJS.DOM.Enums

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

2021import GHCJS.DOM.EventTarget (dispatchEvent)

2122import GHCJS.DOM.Types hiding (Text)

2223import GHCJS.DOM.XMLHttpRequest

23−-- import GHCJS.Types

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

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

2426import Prelude hiding (error)

2527import Reflex.Dom.Xhr.Exception

2628import 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)

3329

3430xmlHttpRequestNew :: MonadJSM m => m XMLHttpRequest

3531xmlHttpRequestNew = newXMLHttpRequest

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

6561instance IsXhrPayload Blob where

6662 sendXhrPayload = sendBlob

6763

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+

6870newtype XhrPayload = XhrPayload { unXhrPayload :: JSVal }

6971

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

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

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

179181 Just XhrResponseType_ArrayBuffer -> case fmap unGObject mr of

180182 Nothing -> return Nothing

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

183+ Just ptr -> do

184+ ab <- liftJSM $ mutableArrayBufferFromJSVal ptr

185+ Just . XhrResponseBody_ArrayBuffer <$> bsFromMutableArrayBuffer ab

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