ec6682c · reflex-dom · git.iko.soy

git.iko.soy/reflex-dom

on develop help sign in

Improve the performance of DynamicWriter

ec6682cRyan Trinkle10 years ago

src/Foreign/JavaScript/TH.hs+1−1

compare with develop

unifiedsplit

@@ -127,7 +127,7 @@ instance PerformEvent t m => PerformEvent t (WithWebView x m) where

127

128instance Deletable t m => Deletable t (WithWebView x m) where

129 {-# INLINABLE deletable #-}

130− deletable e = liftThrough $ deletable e

130+ deletable = liftThrough . deletable

131

132runWithWebView :: WithWebView x m a -> WebViewSingleton x -> m a

133runWithWebView = runReaderT . unWithWebView

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

@@ -40,8 +40,6 @@ class (Monad m, Reflex t, Deletable t m, DomSpace (DomBuilderSpace m)) => DomBui

40 type DomBuilderSpace m :: *

41 textNode :: TextNodeConfig t -> m (TextNode t)

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

43− -- | Create a section of DOM that can be completely deleted (no trace will be left once it is deleted)

44− fragment :: FragmentConfig above t m -> m a -> m (Fragment above t, a)

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

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

46 -- The provided DOM will be executed after the current frame, so it will not be affected by any occurrences that are concurrent with the occurrence that created it

44 -- The provided DOM will be executed after the current frame, so it will not be affected by any occurrences that are concurrent with the occurrence that created it

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

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

@@ -140,23 +138,6 @@ data Placeholder above t

140 , _placeholder_deleted :: Event t ()

138 , _placeholder_deleted :: Event t ()

141 }

139 }

142

140

143−data FragmentConfig above t m

144− = FragmentConfig { _fragmentConfig_deleteSelf :: Event t ()

145− , _fragmentConfig_insertAbove :: Event t (m above)

146− }

147−

148−instance (Reflex t, above ~ ()) => Default (FragmentConfig above t m) where

149− {-# INLINABLE def #-}

150− def = FragmentConfig

151− { _fragmentConfig_deleteSelf = never

152− , _fragmentConfig_insertAbove = never

153− }

154−

155−data Fragment above t

156− = Fragment { _fragment_insertedAbove :: Event t above

157− , _fragment_deleted :: Event t ()

158− }

159−

160data InputElementConfig er t m

141data InputElementConfig er t m

161 = InputElementConfig { _inputElementConfig_initialValue :: Text

142 = InputElementConfig { _inputElementConfig_initialValue :: Text

162 , _inputElementConfig_setValue :: Event t Text

143 , _inputElementConfig_setValue :: Event t Text

@@ -206,7 +187,6 @@ data TextAreaElement er d t

206

187

207makeLenses ''TextNodeConfig

188makeLenses ''TextNodeConfig

208makeLenses ''ElementConfig

189makeLenses ''ElementConfig

209−makeLenses ''FragmentConfig

210makeLenses ''PlaceholderConfig

190makeLenses ''PlaceholderConfig

211makeLenses ''InputElementConfig

191makeLenses ''InputElementConfig

212makeLenses ''TextAreaElementConfig

192makeLenses ''TextAreaElementConfig

@@ -214,10 +194,6 @@ makeLenses ''TextAreaElementConfig

214class CanDeleteSelf t a | a -> t where

194class CanDeleteSelf t a | a -> t where

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

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

216

196

217−instance CanDeleteSelf t (FragmentConfig above t m) where

218− {-# INLINABLE deleteSelf #-}

219− deleteSelf = fragmentConfig_deleteSelf

220−

221instance CanDeleteSelf t (PlaceholderConfig above t m) where

197instance CanDeleteSelf t (PlaceholderConfig above t m) where

222 {-# INLINABLE deleteSelf #-}

198 {-# INLINABLE deleteSelf #-}

223 deleteSelf = placeholderConfig_deleteSelf

199 deleteSelf = placeholderConfig_deleteSelf

@@ -225,8 +201,8 @@ instance CanDeleteSelf t (PlaceholderConfig above t m) where

225class InsertAbove t m above above' a a' | a -> t m above, a' -> t m above', a above' -> a', a' above -> a where

201class InsertAbove t m above above' a a' | a -> t m above, a' -> t m above', a above' -> a', a' above -> a where

226 insertAbove :: Lens a a' (Event t (m above)) (Event t (m above'))

202 insertAbove :: Lens a a' (Event t (m above)) (Event t (m above'))

227

203

228−instance InsertAbove t m above above' (FragmentConfig above t m) (FragmentConfig above' t m) where

204+instance InsertAbove t m above above' (PlaceholderConfig above t m) (PlaceholderConfig above' t m) where

229− insertAbove = fragmentConfig_insertAbove

205+ insertAbove = placeholderConfig_insertAbove

230

206

231class InitialAttributes a where

207class InitialAttributes a where

232 initialAttributes :: Lens' a (Map AttributeName Text)

208 initialAttributes :: Lens' a (Map AttributeName Text)

@@ -265,12 +241,6 @@ instance Functor1 (ElementConfig er t) where

265 , _elementConfig_eventHandler = _elementConfig_eventHandler cfg

241 , _elementConfig_eventHandler = _elementConfig_eventHandler cfg

266 }

242 }

267

243

268−instance Reflex t => Functor1 (FragmentConfig above t) where

269− {-# INLINABLE fmap1 #-}

270− fmap1 f cfg = cfg

271− { _fragmentConfig_insertAbove = fmap f $ _fragmentConfig_insertAbove cfg

272− }

273−

274instance Reflex t => Functor1 (PlaceholderConfig above t) where

244instance Reflex t => Functor1 (PlaceholderConfig above t) where

275 {-# INLINABLE fmap1 #-}

245 {-# INLINABLE fmap1 #-}

276 fmap1 f cfg = cfg

246 fmap1 f cfg = cfg

@@ -285,10 +255,6 @@ instance Functor1 (TextAreaElementConfig er t) where

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

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

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

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

287

257

288−{-# INLINABLE deletableFragment #-}

289−deletableFragment :: DomBuilder t m => Event t () -> m a -> m a

290−deletableFragment d c = fmap snd $ fragment (def & deleteSelf .~ d) c

291−

292class HasDomEvent t target eventName where

258class HasDomEvent t target eventName where

293 type DomEventType target eventName :: *

259 type DomEventType target eventName :: *

294 domEvent :: EventName eventName -> target -> Event t (DomEventType target eventName)

260 domEvent :: EventName eventName -> target -> Event t (DomEventType target eventName)

@@ -313,7 +279,6 @@ instance DomBuilder t m => DomBuilder t (ReaderT r m) where

313 {-# INLINABLE textNode #-}

279 {-# INLINABLE textNode #-}

314 textNode = liftTextNode

280 textNode = liftTextNode

315 element = liftElement

281 element = liftElement

316− fragment = liftFragment

317 placeholder = liftPlaceholder

282 placeholder = liftPlaceholder

318 inputElement = liftInputElement

283 inputElement = liftInputElement

319 textAreaElement = liftTextAreaElement

284 textAreaElement = liftTextAreaElement

@@ -350,9 +315,6 @@ liftTextNode = lift . textNode

350liftElement :: LiftDomBuilder t f m => Text -> ElementConfig er t (f m) -> f m a -> f m (Element er (DomBuilderSpace m) t, a)

315liftElement :: LiftDomBuilder t f m => Text -> ElementConfig er t (f m) -> f m a -> f m (Element er (DomBuilderSpace m) t, a)

351liftElement elementTag cfg child = liftWithStateless $ \run -> element elementTag (fmap1 run cfg) $ run child

316liftElement elementTag cfg child = liftWithStateless $ \run -> element elementTag (fmap1 run cfg) $ run child

352

317

353−liftFragment :: LiftDomBuilder t f m => FragmentConfig above t (f m) -> f m a -> f m (Fragment above t, a)

354−liftFragment cfg child = liftWithStateless $ \run -> fragment (fmap1 run cfg) $ run child

355−

356liftPlaceholder :: LiftDomBuilder t f m => PlaceholderConfig above t (f m) -> f m (Placeholder above t)

318liftPlaceholder :: LiftDomBuilder t f m => PlaceholderConfig above t (f m) -> f m (Placeholder above t)

357liftPlaceholder cfg = liftWithStateless $ \run -> placeholder $ fmap1 run cfg

319liftPlaceholder cfg = liftWithStateless $ \run -> placeholder $ fmap1 run cfg

358

320

src/Reflex/Dom/Builder/Immediate.hs+7−10

@@ -190,15 +190,6 @@ instance SupportsImmediateDomBuilder t m => DomBuilder t (ImmediateDomBuilderT t

190 return TextNode

191 {-# INLINABLE element #-}

192 element elementTag cfg child = fst <$> makeElement elementTag cfg child

193− {-# INLINABLE fragment #-}

194− fragment cfg child = liftThrough (deletable $ cfg ^. deleteSelf) $ do

195− top <- textNodeInternal ("" :: Text)

196− result <- child

197− bottom <- textNodeInternal ("" :: Text)

198− insertedAbove <- insertImmediateAbove top $ cfg ^. fragmentConfig_insertAbove

199− deleted <- lift $ performEvent $ ffor (cfg ^. deleteSelf) $ \_ -> do

200− deleteBetweenInclusive top bottom

201− return (Fragment insertedAbove deleted, result)

202 {-# INLINABLE placeholder #-}

193 {-# INLINABLE placeholder #-}

203 placeholder (PlaceholderConfig toInsertAbove delete) = liftThrough (deletable delete) $ do

194 placeholder (PlaceholderConfig toInsertAbove delete) = liftThrough (deletable delete) $ do

204 n <- textNodeInternal ("" :: Text)

195 n <- textNodeInternal ("" :: Text)

@@ -268,7 +259,13 @@ insertImmediateAbove n toInsertAbove = do

268

259

269instance SupportsImmediateDomBuilder t m => Deletable t (ImmediateDomBuilderT t m) where

260instance SupportsImmediateDomBuilder t m => Deletable t (ImmediateDomBuilderT t m) where

270 {-# INLINABLE deletable #-}

261 {-# INLINABLE deletable #-}

271− deletable = deletableFragment

262+ deletable delete child = liftThrough (deletable delete) $ do

263+ top <- textNodeInternal ("" :: Text)

264+ result <- child

265+ bottom <- textNodeInternal ("" :: Text)

266+ lift $ performEvent_ $ ffor delete $ \_ -> do

267+ deleteBetweenInclusive top bottom

268+ return result

272

269

273instance PerformEvent t m => PerformEvent t (ImmediateDomBuilderT t m) where

270instance PerformEvent t m => PerformEvent t (ImmediateDomBuilderT t m) where

274 type Performable (ImmediateDomBuilderT t m) = Performable m

271 type Performable (ImmediateDomBuilderT t m) = Performable m

src/Reflex/Dom/Deletable/Class.hs+1−1

@@ -11,4 +11,4 @@ class (Reflex t, Monad m) => Deletable t m | m -> t where

12instance Deletable t m => Deletable t (ReaderT r m) where

13 {-# INLINABLE deletable #-}

14− deletable e = liftThrough $ deletable e

14+ deletable = liftThrough . deletable

src/Reflex/Dom/DynamicWriter.hs+118−32

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

1−{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TypeFamilies, GeneralizedNewtypeDeriving, UndecidableInstances, StandaloneDeriving, FunctionalDependencies, RecursiveDo #-}

1+{-# LANGUAGE CPP, FlexibleInstances, MultiParamTypeClasses, TypeFamilies, GeneralizedNewtypeDeriving, UndecidableInstances, StandaloneDeriving, FunctionalDependencies, RecursiveDo, ScopedTypeVariables, LambdaCase, GADTs #-}

2module Reflex.Dom.DynamicWriter where

4import Reflex

@@ -14,11 +14,85 @@ import Control.Monad.State.Strict

14import Control.Monad.Reader

15import Control.Monad.Ref

16import Control.Monad.Exception

17+import Data.Map (Map)

18+import qualified Data.Map as Map

19+import Data.Dependent.Map (DMap)

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

21+import Data.Functor.Compose

22+import Data.Functor.Misc

23+import Data.Semigroup

24+import Data.Foldable

25+import Data.Traversable

18instance MonadTrans (DynamicWriterT t w) where

27instance MonadTrans (DynamicWriterT t w) where

19 lift = DynamicWriterT . lift

28 lift = DynamicWriterT . lift

30+data PatchMap a where

31+ PatchMap :: Ord k => Map k (Maybe v) -> PatchMap (Map k v)

32+

33+instance Patch PatchMap where

34+ apply (PatchMap p) old = Just $! insertions `Map.union` (old `Map.difference` deletions) --TODO: return Nothing sometimes --Note: the strict application here is critical to ensuring that incremental merges don't hold onto all their prerequisite events forever; can we make this more robust?

35+ where insertions = Map.mapMaybeWithKey (const id) p

36+ deletions = Map.mapMaybeWithKey (const nothingToJust) p

37+ nothingToJust = \case

38+ Nothing -> Just ()

39+ Just _ -> Nothing

40+

41+instance Ord k => Semigroup (PatchMap (Map k v)) where

42+ PatchMap a <> PatchMap b = PatchMap $ a `mappend` b --TODO: Add a semigroup instance for Map

43+ -- PatchMap is idempotent, so stimes n is id for every n

44+#if MIN_VERSION_semigroups(0,17,0)

45+ stimes = stimesIdempotentMonoid

46+#else

47+ times1p n x = case compare n 0 of

48+ LT -> error "stimesIdempotentMonoid: negative multiplier"

49+ EQ -> mempty

50+ GT -> x

51+#endif

52+

53+instance Ord k => Monoid (PatchMap (Map k v)) where

54+ mempty = PatchMap mempty

55+ mappend = (<>)

56+

57+mconcatIncremental :: (Reflex t, MonadHold t m, MonadFix m, Monoid v) => Map k v -> Event t (PatchMap (Map k v)) -> m (Dynamic t v)

58+mconcatIncremental m0 e = do

59+ d <- foldDynMaybe apply m0 e

60+ return $ fmap (mconcat . Map.elems) d

61+

62+mapIncrementalMapValuesWithKey :: Reflex t => (k -> v -> v') -> Incremental t PatchMap (Map k v) -> Incremental t PatchMap (Map k v')

63+mapIncrementalMapValuesWithKey f = unsafeMapIncremental (Map.mapWithKey f) $ \(PatchMap m) -> PatchMap $ Map.mapWithKey (\k mv -> fmap (f k) mv) m

64+

65+mapIncrementalMapValues :: Reflex t => (v -> v') -> Incremental t PatchMap (Map k v) -> Incremental t PatchMap (Map k v')

66+mapIncrementalMapValues f = mapIncrementalMapValuesWithKey $ const f

67+

68+unsafeMapIncremental :: (Reflex t, Patch p, Patch p') => (a -> a') -> (p a -> p' a') -> Incremental t p a -> Incremental t p' a'

69+unsafeMapIncremental f g a = unsafeBuildIncremental (fmap f $ sample $ currentIncremental a) $ fmap g $ updatedIncremental a

70+

71+incrementalExtractFunctorDMap :: Reflex t => Incremental t PatchMap (Map k (f v)) -> Incremental t PatchDMap (DMap (Const2 k v) f)

72+incrementalExtractFunctorDMap = unsafeMapIncremental mapWithFunctorToDMap $ \(PatchMap m) -> PatchDMap $ mapWithFunctorToDMap $ fmap Compose m

73+

74+mergeIncrementalMap :: (Reflex t, Ord k) => Incremental t PatchMap (Map k (Event t v)) -> Event t (Map k v)

75+mergeIncrementalMap = fmap dmapToMap . mergeIncremental . incrementalExtractFunctorDMap

76+

77+incrementalReplaceableMap :: (Reflex t, MonadHold t m, MonadFix m, Ord k) => Map k (Replaceable t v) -> Event t (PatchMap (Map k (Replaceable t v))) -> m (Incremental t PatchMap (Map k v))

78+incrementalReplaceableMap v0 e = do

79+ rec vals <- holdIncremental v0 $ e <> valChanges

80+ let valChanges = fmap PatchMap $ mergeIncrementalMap $ mapIncrementalMapValues _replaceable_modify vals

81+ return $ mapIncrementalMapValues _replaceable_value vals

82+

83+mergeDynIncremental :: (Reflex t, Ord k) => Incremental t PatchMap (Map k (Dynamic t v)) -> Incremental t PatchMap (Map k v)

84+mergeDynIncremental a = unsafeBuildIncremental (mapM (sample . current) =<< sample (currentIncremental a)) $ addedAndRemovedValues <> changedValues

85+ where changedValues = fmap (PatchMap . fmap Just) $ mergeIncrementalMap $ mapIncrementalMapValues updated a

86+ addedAndRemovedValues = flip pushAlways (updatedIncremental a) $ \(PatchMap m) -> PatchMap <$> mapM (mapM (sample . current)) m

87+

88+data Replaceable t w = Replaceable

89+ { _replaceable_value :: w

90+ , _replaceable_modify :: Event t (Maybe (Replaceable t w)) -- "Please delete" is represented with an event of Nothing; all subsequent events will be ignored

91+ }

92+

93+type DynamicWriterAccumulator t w = [Replaceable t (Dynamic t w)]

94+

21−newtype DynamicWriterT t w m a = DynamicWriterT { unDynamicWriterT :: StateT [Dynamic t w] m a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadHold t, MonadSample t, MonadAsyncException, MonadException) -- The list is kept in reverse order

95+newtype DynamicWriterT t w m a = DynamicWriterT { unDynamicWriterT :: StateT (DynamicWriterAccumulator t w) m a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadHold t, MonadSample t, MonadAsyncException, MonadException) -- The list is kept in reverse order

23instance HasWebView m => HasWebView (DynamicWriterT t w m) where

97instance HasWebView m => HasWebView (DynamicWriterT t w m) where

24 type WebViewPhantom (DynamicWriterT t w m) = WebViewPhantom m

98 type WebViewPhantom (DynamicWriterT t w m) = WebViewPhantom m

@@ -37,24 +111,31 @@ instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (DynamicWrit

37 newEventWithTrigger = lift . newEventWithTrigger

111 newEventWithTrigger = lift . newEventWithTrigger

38 newFanEventWithTrigger f = lift $ newFanEventWithTrigger f

112 newFanEventWithTrigger f = lift $ newFanEventWithTrigger f

113

114+runDynamicWriterTInternal :: DynamicWriterT t w m a -> m (a, DynamicWriterAccumulator t w)

115+runDynamicWriterTInternal (DynamicWriterT a) = runStateT a []

116+

117+mconcatIncrementalReplaceableDynMap :: (Reflex t, Monoid v, Ord k) => Incremental t PatchMap (Map k (Dynamic t v)) -> Dynamic t v

118+mconcatIncrementalReplaceableDynMap = fmap (mconcat . Map.elems) . incrementalToDynamic . mergeDynIncremental

119+

40−runDynamicWriterT :: (Reflex t, MonadHold t m, Monoid w) => DynamicWriterT t w m a -> m (a, Dynamic t w)

120+runDynamicWriterT :: (Reflex t, MonadHold t m, Monoid w, MonadFix m) => DynamicWriterT t w m a -> m (a, Dynamic t w)

41runDynamicWriterT (DynamicWriterT a) = do

121runDynamicWriterT (DynamicWriterT a) = do

42 (result, ws) <- runStateT a []

122 (result, ws) <- runStateT a []

43− w <- mconcatDyn $ reverse ws

123+ i <- incrementalReplaceableMap (Map.fromList $ zip [1 :: Int ..] $ reverse ws) never

124+ let w = mconcatIncrementalReplaceableDynMap i

44 return (result, w)

125 return (result, w)

126

46class Monad m => MonadDynamicWriter t w m | m -> t w where

127class Monad m => MonadDynamicWriter t w m | m -> t w where

47 tellDyn :: Dynamic t w -> m ()

128 tellDyn :: Dynamic t w -> m ()

129

49−instance Monad m => MonadDynamicWriter t w (DynamicWriterT t w m) where

130+instance (Monad m, Reflex t) => MonadDynamicWriter t w (DynamicWriterT t w m) where

50− tellDyn w = DynamicWriterT $ modify (w:)

131+ tellDyn w = DynamicWriterT $ modify (Replaceable w never :)

132

52instance MonadReader r m => MonadReader r (DynamicWriterT t w m) where

133instance MonadReader r m => MonadReader r (DynamicWriterT t w m) where

53 ask = lift ask

134 ask = lift ask

54 local f (DynamicWriterT a) = DynamicWriterT $ mapStateT (local f) a

135 local f (DynamicWriterT a) = DynamicWriterT $ mapStateT (local f) a

55 reader = lift . reader

136 reader = lift . reader

137

57−liftDynamicWriterTThroughSync :: Monad m' => (m (a, [Dynamic t w]) -> m' (b, (a, [Dynamic t w]))) -> DynamicWriterT t w m a -> DynamicWriterT t w m' (b, a)

138+liftDynamicWriterTThroughSync :: Monad m' => (m (a, DynamicWriterAccumulator t w) -> m' (b, (a, DynamicWriterAccumulator t w))) -> DynamicWriterT t w m a -> DynamicWriterT t w m' (b, a)

58liftDynamicWriterTThroughSync f (DynamicWriterT child) = DynamicWriterT $ do

139liftDynamicWriterTThroughSync f (DynamicWriterT child) = DynamicWriterT $ do

59 s <- get

140 s <- get

60 (b, (a, newS)) <- lift $ f $ runStateT child s

141 (b, (a, newS)) <- lift $ f $ runStateT child s

@@ -65,7 +146,7 @@ liftDynamicWriterTThroughSync f (DynamicWriterT child) = DynamicWriterT $ do

65liftDynamicWriterTElementConfig :: ElementConfig er t (DynamicWriterT t w m) -> ElementConfig er t m

146liftDynamicWriterTElementConfig :: ElementConfig er t (DynamicWriterT t w m) -> ElementConfig er t m

66liftDynamicWriterTElementConfig cfg = cfg

147liftDynamicWriterTElementConfig cfg = cfg

67 { _elementConfig_eventFilters = _elementConfig_eventFilters cfg

148 { _elementConfig_eventFilters = _elementConfig_eventFilters cfg

68− , _elementConfig_eventHandler = _elementConfig_eventHandler cfg -- This requires PolyKinds, and will fail to unify types otherwise

149+ , _elementConfig_eventHandler = _elementConfig_eventHandler cfg

69 }

150 }

151

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

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

@@ -80,41 +161,46 @@ instance (DomBuilder t m, Monoid w, MonadHold t m, MonadFix m) => DomBuilder t (

80 (el, (a, newS)) <- lift $ element elementTag cfg' $ runStateT child s

161 (el, (a, newS)) <- lift $ element elementTag cfg' $ runStateT child s

81 put newS

162 put newS

82 return (el, a)

163 return (el, a)

83− fragment cfg (DynamicWriterT child) = do --TODO: Delete these things

84− s <- DynamicWriterT get

85− let cfg' = cfg

86− { _fragmentConfig_insertAbove = fmap runDynamicWriterT $ _fragmentConfig_insertAbove cfg

87− }

88− rec children <- foldDyn (:) [] childOutputs

89− tellDyn $ mconcat =<< children -- Needs to go above the child to preserve order

90− (f, (a, newS)) <- DynamicWriterT $ lift $ fragment cfg' $ runStateT child s

91− DynamicWriterT $ put newS

92− let result = fmap fst $ _fragment_insertedAbove f

93− childOutputs = fmap snd $ _fragment_insertedAbove f

94− let f' = f

95− { _fragment_insertedAbove = result

96− }

97− return (f', a)

98− placeholder cfg = do --TODO: Delete these things

164+ placeholder cfg = do

99 let cfg' = cfg

165 let cfg' = cfg

100− { _placeholderConfig_insertAbove = fmap runDynamicWriterT $ _placeholderConfig_insertAbove cfg

166+ { _placeholderConfig_insertAbove = fmap runDynamicWriterTInternal $ _placeholderConfig_insertAbove cfg

101 }

167 }

102− rec children <- foldDyn (:) [] childOutputs

168+ let manageChildren :: Event t (NonEmpty (Replaceable t (Dynamic t w))) -- ^ Add nodes on the right; these are in reverse order

103− tellDyn $ mconcat =<< children -- Needs to go above the child to preserve order

169+ -> Event t () -- ^ No more nodes will be added after this event fires

170+ -> m (Replaceable t (Dynamic t w))

171+ manageChildren newChildren additionsCeased = do

172+ rec nextId <- hold (0 :: Int) newNextId -- We assume this will never wrap around

173+ let numberedNewChildren :: Event t (Int, PatchMap (Map Int (Replaceable t (Dynamic t w))))

174+ numberedNewChildren = flip pushAlways newChildren $ \rcs -> do

175+ let cs = reverse $ toList rcs

176+ myFirstId <- sample nextId

177+ let (myNextId, numbered) = mapAccumL (\n v -> (succ n, (n, Just v))) myFirstId cs

178+ return (myNextId, PatchMap $ Map.fromList numbered)

179+ newNextId = fst <$> numberedNewChildren

180+ replaceableMap <- incrementalReplaceableMap Map.empty $ snd <$> numberedNewChildren

181+ noMoreAdditions <- holdDyn False $ True <$ additionsCeased

182+ let replaceSelf nma i = do

183+ guard nma

184+ case Map.toList i of

185+ [] -> return Nothing -- Delete self

186+ _ -> mzero

187+ return $ Replaceable (mconcatIncrementalReplaceableDynMap replaceableMap) $ fmapMaybe id $ updated $ zipDynWith replaceSelf noMoreAdditions $ incrementalToDynamic replaceableMap

188+ rec children <- lift $ manageChildren childOutputs $ cfg ^. deleteSelf

189+ p <- DynamicWriterT $ do

190+ modify (children:)

104− p <- DynamicWriterT $ lift $ placeholder cfg'

191+ lift $ placeholder cfg'

105 let result = fmap fst $ _placeholder_insertedAbove p

192 let result = fmap fst $ _placeholder_insertedAbove p

106− childOutputs = fmap snd $ _placeholder_insertedAbove p

193+ childOutputs = fmapMaybe (nonEmpty . snd) $ _placeholder_insertedAbove p

107 return $ p

194 return $ p

108 { _placeholder_insertedAbove = result

195 { _placeholder_insertedAbove = result

109 }

196 }

110 inputElement cfg = lift $ inputElement $ cfg & inputElementConfig_elementConfig %~ liftDynamicWriterTElementConfig

197 inputElement cfg = lift $ inputElement $ cfg & inputElementConfig_elementConfig %~ liftDynamicWriterTElementConfig

111 textAreaElement cfg = lift $ textAreaElement $ cfg & textAreaElementConfig_elementConfig %~ liftDynamicWriterTElementConfig

198 textAreaElement cfg = lift $ textAreaElement $ cfg & textAreaElementConfig_elementConfig %~ liftDynamicWriterTElementConfig

112

199

113−instance (Deletable t m, Reflex t, Monoid w, MonadHold t m) => Deletable t (DynamicWriterT t w m) where

200+instance (Deletable t m, Reflex t, Monoid w, MonadHold t m, MonadFix m) => Deletable t (DynamicWriterT t w m) where

114 deletable delete child = do

201 deletable delete child = do

115 (result, output) <- lift $ deletable delete $ runDynamicWriterT child

202 (result, output) <- lift $ deletable delete $ runDynamicWriterT child

116− output' <- holdDyn output $ constDyn mempty <$ delete

203+ DynamicWriterT $ modify (Replaceable output (Nothing <$ delete) :)

117− tellDyn $ join output'

118 return result

204 return result

119

205

120instance PerformEvent t m => PerformEvent t (DynamicWriterT t w m) where

206instance PerformEvent t m => PerformEvent t (DynamicWriterT t w m) where

src/Reflex/Dom/PerformEvent/Base.hs+1−1

@@ -82,7 +82,7 @@ mergePerformEventsAndAdd :: forall t m. ReflexHost t

82mergePerformEventsAndAdd initial eAddNew = do

83 rec events :: Incremental t PatchDMap (DMap (Const2 Word64 (These (PerformEventT t m [DSum (EventTriggerRef t m) Identity]) ())) (Event t))

84 <- holdIncremental initial $ eAddNew <> eDelete

85− let event = mergeIncremental events

85+ let event = mergeWith DMap.union [mergeIncremental events, coincidence (fmap (\(PatchDMap m) -> merge $ DMap.mapMaybeWithKey (const getCompose) m) eAddNew)]

86 eventToPerform :: Event t (PerformEventT t m [DSum (EventTriggerRef t m) Identity])

87 eventToPerform = ffor event $

88 fmap concat .

src/Reflex/Dom/PostBuild/Class.hs+4−18

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

1−{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, GeneralizedNewtypeDeriving, TypeFamilies, UndecidableInstances, RecursiveDo, ScopedTypeVariables, DataKinds, TypeOperators, PolyKinds #-}

1+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, GeneralizedNewtypeDeriving, TypeFamilies, UndecidableInstances, RecursiveDo, ScopedTypeVariables, DataKinds, TypeOperators, PolyKinds, FunctionalDependencies #-}

2module Reflex.Dom.PostBuild.Class where

4import Reflex

@@ -13,7 +13,7 @@ import Control.Monad.Trans.Control

13import Control.Monad.Ref

14import Control.Monad.Exception

16−class (Reflex t, Monad m) => PostBuild t m where

16+class (Reflex t, Monad m) => PostBuild t m | m -> t where

17 getPostBuild :: m (Event t ())

19newtype PostBuildT t m a = PostBuildT { unPostBuildT :: ReaderT (Event t ()) m a } deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadTrans, MonadException, MonadAsyncException)

@@ -31,7 +31,7 @@ instance (Reflex t, Monad m) => PostBuild t (PostBuildT t m) where

32instance Deletable t m => Deletable t (PostBuildT t m) where

33 {-# INLINABLE deletable #-}

34− deletable d = liftThrough $ deletable d

34+ deletable = liftThrough . deletable

36{-# INLINABLE liftPostBuildTElementConfig #-}

37liftPostBuildTElementConfig :: ElementConfig er t (PostBuildT t m) -> ElementConfig er t m

@@ -46,23 +46,9 @@ instance (DomBuilder t m, PerformEvent t m, MonadFix m, MonadHold t m) => DomBui

46 textNode = lift . textNode

47 {-# INLINABLE element #-}

48 element t cfg child = liftWith $ \run -> element t (liftPostBuildTElementConfig cfg) $ run child

49− {-# INLINABLE fragment #-}

50− fragment cfg child = liftWith $ \run -> do

51− rec (delayedDelete, childPostBuild) <- deletable delayedDelete $ do

52− delayedDeleteInner <- performEvent $ return () <$ cfg ^. deleteSelf

53− childPostBuildInner <- performEvent $ return () <$ _fragment_insertedAbove f

54− return (delayedDeleteInner, childPostBuildInner)

55− let cfg' = cfg

56− { _fragmentConfig_insertAbove = fmap (\a -> runPostBuildT a =<< headE childPostBuild) $ _fragmentConfig_insertAbove cfg

57− }

58− (f, result) <- fragment cfg' $ run child

59− return (f, result)

60 {-# INLINABLE placeholder #-}

49 {-# INLINABLE placeholder #-}

61 placeholder cfg = lift $ do

50 placeholder cfg = lift $ do

62− rec (delayedDelete, childPostBuild) <- deletable delayedDelete $ do

63− delayedDeleteInner <- performEvent $ return () <$ cfg ^. deleteSelf

64− childPostBuildInner <- performEvent $ return () <$ _placeholder_insertedAbove p

51+ rec childPostBuild <- deletable (cfg ^. deleteSelf) $ performEvent $ return () <$ _placeholder_insertedAbove p

65− return (delayedDeleteInner, childPostBuildInner)

66 p <- placeholder $ cfg

52 p <- placeholder $ cfg

67 { _placeholderConfig_insertAbove = fmap (\a -> runPostBuildT a =<< headE childPostBuild) $ _placeholderConfig_insertAbove cfg

53 { _placeholderConfig_insertAbove = fmap (\a -> runPostBuildT a =<< headE childPostBuild) $ _placeholderConfig_insertAbove cfg

68 }

54 }

src/Reflex/Dom/Widget/Basic.hs+10−17

@@ -63,8 +63,9 @@ listHoldWithKey initialChildren modifyChildren buildChild = do

63 myCfg = def

64 & insertAbove .~ fmap (imapM buildAugmentedChild) (select placeChildSelector $ Const2 $ Left k)

65 & deleteSelf .~ delete

66− (me, result) <- fragment myCfg $ buildChild k v

66+ ph <- placeholder myCfg

67+ result <- deletable delete $ buildChild k v

67− return $ ChildResult (result, (fmap (fmap Just) $ _fragment_insertedAbove me) <> (Map.singleton k Nothing <$ _fragment_deleted me)) --Note: we could also use the "deleted" output on deletable, if it had one; we're using this so that everything changes all at once, instead of deletions being prompt and insertions being delayed

68+ return $ ChildResult (result, (fmap (fmap Just) $ _placeholder_insertedAbove ph) <> (Map.singleton k Nothing <$ _placeholder_deleted ph)) --Note: we could also use the "deleted" output on deletable, if it had one; we're using this so that everything changes all at once, instead of deletions being prompt and insertions being delayed

68 rec initialAugmentedResults <- iforM initialChildren buildAugmentedChild

69 rec initialAugmentedResults <- iforM initialChildren buildAugmentedChild

69 augmentedResults <- foldDyn applyMap initialAugmentedResults $ newInsertedBelow <> newInsertedAbove

70 augmentedResults <- foldDyn applyMap initialAugmentedResults $ newInsertedBelow <> newInsertedAbove

70 let newInsertedAbove = switch $ fmap (mconcat . reverse . fmap (snd . unChildResult) . Map.elems) $ current augmentedResults

71 let newInsertedAbove = switch $ fmap (mconcat . reverse . fmap (snd . unChildResult) . Map.elems) $ current augmentedResults

@@ -145,13 +146,6 @@ applyMapKeysSet :: Ord k => Map k (Maybe v) -> Set k -> Set k

145applyMapKeysSet patch old = Map.keysSet insertions `Set.union` (old `Set.difference` Map.keysSet deletions)

146applyMapKeysSet patch old = Map.keysSet insertions `Set.union` (old `Set.difference` Map.keysSet deletions)

146 where (insertions, deletions) = Map.partition isJust patch

147 where (insertions, deletions) = Map.partition isJust patch

147

148

148−--HACK: A listWithKey that is inefficient but works around a subtle buggy interaction with DynamicWriterT

149−listWithKey :: forall t k v m a. (PostBuild t m, DomBuilder t m, MonadHold t m) => Dynamic t (Map k v) -> (k -> Dynamic t v -> m a) -> m (Dynamic t (Map k a))

150−listWithKey eltsMapD body = do

151− pb <- getPostBuild

152− widgetHold (return Map.empty) $ ffor (leftmost [ tagDyn eltsMapD pb, updated eltsMapD ]) $ imapM $ \k v -> body k (constDyn v)

153−

154−{-

155--TODO: Something better than Dynamic t (Map k v) - we want something where the Events carry diffs, not the whole value

149--TODO: Something better than Dynamic t (Map k v) - we want something where the Events carry diffs, not the whole value

156listWithKey :: forall t k v m a. (Ord k, DomBuilder t m, PostBuild t m, MonadFix m, MonadHold t m) => Dynamic t (Map k v) -> (k -> Dynamic t v -> m a) -> m (Dynamic t (Map k a))

150listWithKey :: forall t k v m a. (Ord k, DomBuilder t m, PostBuild t m, MonadFix m, MonadHold t m) => Dynamic t (Map k v) -> (k -> Dynamic t v -> m a) -> m (Dynamic t (Map k a))

157listWithKey vals mkChild = do

151listWithKey vals mkChild = do

@@ -164,7 +158,6 @@ listWithKey vals mkChild = do

164 ]

158 ]

165 listWithKeyShallowDiff Map.empty changeVals $ \k v0 dv -> do

159 listWithKeyShallowDiff Map.empty changeVals $ \k v0 dv -> do

166 mkChild k =<< holdDyn v0 dv

160 mkChild k =<< holdDyn v0 dv

167−-}

168

161

169{-# DEPRECATED listWithKey' "listWithKey' has been renamed to listWithKeyShallowDiff; also, its behavior has changed to fix a bug where children were always rebuilt (never updated)" #-}

162{-# DEPRECATED listWithKey' "listWithKey' has been renamed to listWithKeyShallowDiff; also, its behavior has changed to fix a bug where children were always rebuilt (never updated)" #-}

170listWithKey' :: (Ord k, DomBuilder t m, MonadFix m, MonadHold t m) => Map k v -> Event t (Map k (Maybe v)) -> (k -> v -> Event t v -> m a) -> m (Dynamic t (Map k a))

163listWithKey' :: (Ord k, DomBuilder t m, MonadFix m, MonadHold t m) => Map k v -> Event t (Map k (Maybe v)) -> (k -> v -> Event t v -> m a) -> m (Dynamic t (Map k a))

@@ -184,14 +177,14 @@ listWithKeyShallowDiff initialVals valsChanged mkChild = do

184--TODO: Something better than Dynamic t (Map k v) - we want something where the Events carry diffs, not the whole value

177--TODO: Something better than Dynamic t (Map k v) - we want something where the Events carry diffs, not the whole value

185-- | Create a dynamically-changing set of Event-valued widgets.

178-- | Create a dynamically-changing set of Event-valued widgets.

186-- This is like listWithKey, specialized for widgets returning (Event t a). listWithKey would return 'Dynamic t (Map k (Event t a))' in this scenario, but listViewWithKey flattens this to 'Event t (Map k a)' via 'switch'.

179-- This is like listWithKey, specialized for widgets returning (Event t a). listWithKey would return 'Dynamic t (Map k (Event t a))' in this scenario, but listViewWithKey flattens this to 'Event t (Map k a)' via 'switch'.

187−listViewWithKey :: (Ord k, DomBuilder t m, PostBuild t m, MonadHold t m) => Dynamic t (Map k v) -> (k -> Dynamic t v -> m (Event t a)) -> m (Event t (Map k a))

180+listViewWithKey :: (Ord k, DomBuilder t m, PostBuild t m, MonadHold t m, MonadFix m) => Dynamic t (Map k v) -> (k -> Dynamic t v -> m (Event t a)) -> m (Event t (Map k a))

188listViewWithKey vals mkChild = liftM (switch . fmap mergeMap) $ listViewWithKey' vals mkChild

181listViewWithKey vals mkChild = liftM (switch . fmap mergeMap) $ listViewWithKey' vals mkChild

189

182

190−listViewWithKey' :: (DomBuilder t m, PostBuild t m, MonadHold t m) => Dynamic t (Map k v) -> (k -> Dynamic t v -> m a) -> m (Behavior t (Map k a))

183+listViewWithKey' :: (Ord k, DomBuilder t m, PostBuild t m, MonadHold t m, MonadFix m) => Dynamic t (Map k v) -> (k -> Dynamic t v -> m a) -> m (Behavior t (Map k a))

191listViewWithKey' vals mkChild = liftM current $ listWithKey vals mkChild

184listViewWithKey' vals mkChild = liftM current $ listWithKey vals mkChild

192

185

193-- | Create a dynamically-changing set of widgets, one of which is selected at any time.

186-- | Create a dynamically-changing set of widgets, one of which is selected at any time.

194−selectViewListWithKey :: forall t m k v a. (DomBuilder t m, Ord k, PostBuild t m, MonadHold t m)

187+selectViewListWithKey :: forall t m k v a. (DomBuilder t m, Ord k, PostBuild t m, MonadHold t m, MonadFix m)

195 => Dynamic t k -- ^ Current selection key

188 => Dynamic t k -- ^ Current selection key

196 -> Dynamic t (Map k v) -- ^ Dynamic key/value map

189 -> Dynamic t (Map k v) -- ^ Dynamic key/value map

197 -> (k -> Dynamic t v -> Dynamic t Bool -> m (Event t a)) -- ^ Function to create a widget for a given key from Dynamic value and Dynamic Bool indicating if this widget is currently selected

190 -> (k -> Dynamic t v -> Dynamic t Bool -> m (Event t a)) -- ^ Function to create a widget for a given key from Dynamic value and Dynamic Bool indicating if this widget is currently selected

@@ -204,7 +197,7 @@ selectViewListWithKey selection vals mkChild = do

204 return $ fmap ((,) k) selectSelf

197 return $ fmap ((,) k) selectSelf

205 liftM switchPromptlyDyn $ mapDyn (leftmost . Map.elems) selectChild

198 liftM switchPromptlyDyn $ mapDyn (leftmost . Map.elems) selectChild

206

199

207−selectViewListWithKey_ :: forall t m k v a. (DomBuilder t m, Ord k, PostBuild t m, MonadHold t m)

200+selectViewListWithKey_ :: forall t m k v a. (DomBuilder t m, Ord k, PostBuild t m, MonadHold t m, MonadFix m)

208 => Dynamic t k -- ^ Current selection key

201 => Dynamic t k -- ^ Current selection key

209 -> Dynamic t (Map k v) -- ^ Dynamic key/value map

202 -> Dynamic t (Map k v) -- ^ Dynamic key/value map

210 -> (k -> Dynamic t v -> Dynamic t Bool -> m (Event t a)) -- ^ Function to create a widget for a given key from Dynamic value and Dynamic Bool indicating if this widget is currently selected

203 -> (k -> Dynamic t v -> Dynamic t Bool -> m (Event t a)) -- ^ Function to create a widget for a given key from Dynamic value and Dynamic Bool indicating if this widget is currently selected

@@ -291,11 +284,11 @@ elClass elementTag c child = fmap snd $ element elementTag (def & initialAttribu

291

284

292-- | Create a dynamically-changing set of widgets from a Dynamic key/value map.

285-- | Create a dynamically-changing set of widgets from a Dynamic key/value map.

293-- Unlike the 'withKey' variants, the child widgets are insensitive to which key they're associated with.

286-- Unlike the 'withKey' variants, the child widgets are insensitive to which key they're associated with.

294−list :: (DomBuilder t m, MonadHold t m, PostBuild t m) => Dynamic t (Map k v) -> (Dynamic t v -> m a) -> m (Dynamic t (Map k a))

287+list :: (Ord k, DomBuilder t m, MonadHold t m, PostBuild t m, MonadFix m) => Dynamic t (Map k v) -> (Dynamic t v -> m a) -> m (Dynamic t (Map k a))

295list dm mkChild = listWithKey dm (\_ dv -> mkChild dv)

288list dm mkChild = listWithKey dm (\_ dv -> mkChild dv)

296

289

297-- | Create a dynamically-changing set of widgets from a Dynamic list.

290-- | Create a dynamically-changing set of widgets from a Dynamic list.

298−simpleList :: (DomBuilder t m, MonadHold t m, PostBuild t m) => Dynamic t [v] -> (Dynamic t v -> m a) -> m (Dynamic t [a])

291+simpleList :: (DomBuilder t m, MonadHold t m, PostBuild t m, MonadFix m) => Dynamic t [v] -> (Dynamic t v -> m a) -> m (Dynamic t [a])

299simpleList xs mkChild = mapDyn (map snd . Map.toList) =<< flip list mkChild =<< mapDyn (Map.fromList . zip [(1::Int)..]) xs

292simpleList xs mkChild = mapDyn (map snd . Map.toList) =<< flip list mkChild =<< mapDyn (Map.fromList . zip [(1::Int)..]) xs

300

293

301{-

294{-

@@ -356,7 +349,7 @@ blank :: forall m. Monad m => m ()

356blank = return ()

349blank = return ()

357

350

358-- | A widget to display a table with static columns and dynamic rows.

351-- | A widget to display a table with static columns and dynamic rows.

359−tableDynAttr :: forall t m r k v. (DomBuilder t m, MonadHold t m, PostBuild t m)

352+tableDynAttr :: forall t m r k v. (Ord k, DomBuilder t m, MonadHold t m, PostBuild t m, MonadFix m)

360 => Text -- ^ Class applied to <table> element

353 => Text -- ^ Class applied to <table> element

361 -> [(Text, k -> Dynamic t r -> m v)] -- ^ Columns of (header, row key -> row value -> child widget)

354 -> [(Text, k -> Dynamic t r -> m v)] -- ^ Columns of (header, row key -> row value -> child widget)

362 -> Dynamic t (Map k r) -- ^ Map from row key to row value

355 -> Dynamic t (Map k r) -- ^ Map from row key to row value