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

git.iko.soy/reflex-dom

Add listWithKey'

commit5b5a6a7680d612c3822621fd3968c8fca6c27fa4 authorRyan Trinkle <ryan.trinkle@gmail.com> dateThu 26 Feb 2015, 22:07 (12 years ago) parent9fbdadb

3 files changed+55

compare with develop

unifiedsplit

src/Reflex/Dom/Class.hs+2 src/Reflex/Dom/Internal.hs+1 src/Reflex/Dom/Widget/Basic.hs+52

src/Reflex/Dom/Class.hs+2

@@ -57,6 +57,7 @@ class ( Reflex t, MonadHold t m, MonadIO m, Functor m, MonadReflexCreateTrigger

5757 type GuiAction m :: * -> *

5858 askParent :: m Node

5959 subWidget :: Node -> m a -> m a

60+ liftWidgetHost :: WidgetHost m a -> m a --TODO: Is this a good idea?

6061 schedulePostBuild :: WidgetHost m () -> m ()

6162 addVoidAction :: Event t (WidgetHost m ()) -> m ()

6263 getRunWidget :: IsNode n => m (n -> m a -> WidgetHost m (a, Event t (WidgetHost m ())))

@@ -91,6 +92,7 @@ instance MonadWidget t m => MonadWidget t (ReaderT r m) where

9192 subWidget n w = do

9293 r <- ask

9394 lift $ subWidget n $ runReaderT w r

95+ liftWidgetHost = lift . liftWidgetHost

9496 schedulePostBuild = lift . schedulePostBuild

9597 addVoidAction = lift . addVoidAction

9698 getRunWidget = do

src/Reflex/Dom/Internal.hs+1

@@ -144,6 +144,7 @@ instance ( MonadRef m, Ref m ~ Ref IO, MonadRef h, Ref h ~ Ref IO --TODO: Should

144144 --TODO: Use types to separate cohorts of possibly-recursive events/behaviors

145145 -- | Schedule an action to occur after the current cohort has been built; this is necessary because Behaviors built in the current cohort may not be read until after it is complete

146146 --schedulePostBuild :: Monad m => m () -> WidgetInternal t m ()

147+ liftWidgetHost = Widget . lift . lift

147148 schedulePostBuild a = Widget $ widgetStatePostBuild %= (a>>) --TODO: Can this >> be made strict?

148149

149150 --addVoidAction :: Monad m => Event t (m ()) -> WidgetInternal t m ()

src/Reflex/Dom/Widget/Basic.hs+52

@@ -197,6 +197,58 @@ listWithKey vals mkChild = do

197197 liftIO $ putStrLn "Triggering newChildren done"

198198 holdDyn Map.empty $ fmap (fmap (fst . fst)) newChildren

199199

200+listWithKey' :: forall t m k v a. (Ord k, MonadWidget t m) => Map k v -> Event t (Map k (Maybe v)) -> (k -> v -> m a) -> m (Dynamic t (Map k a))

201+listWithKey' initialVals valsChanged mkChild = do

202+ doc <- askDocument

203+ startPlaceholder <- text' ""

204+ endPlaceholder <- text' ""

205+ (newChildren, newChildrenTriggerRef) <- newEventWithTriggerRef

206+-- performEvent_ $ fmap (const $ return ()) newChildren --TODO: Get rid of this hack

207+ runWidget <- getRunWidget

208+ let buildChild :: DocumentFragment -> k -> v -> WidgetHost m ((a, (Text, Text)), Event t (WidgetHost m ()))

209+ buildChild df k v = runWidget df $ do

210+ childStart <- text' ""

211+ result <- mkChild k v

212+ childEnd <- text' ""

213+ return (result, (childStart, childEnd))

214+ Just df <- liftIO $ documentCreateDocumentFragment doc

215+ initialState <- liftWidgetHost $ iforM initialVals $ buildChild df

216+ children <- hold initialState $ traceEventWith (\x -> "newChildren: " <> show (Map.size x)) newChildren

217+ addVoidAction $ switch $ fmap (mergeWith (>>) . map snd . Map.elems) children

218+ Just p <- liftIO $ nodeGetParentNode endPlaceholder

219+ liftIO $ nodeInsertBefore p (Just df) (Just endPlaceholder)

220+ addVoidAction $ flip fmap valsChanged $ \newVals -> do

221+ curState <- sample children

222+ --TODO: Should we remove the parent from the DOM first to avoid reflows?

223+ newState <- liftM (Map.mapMaybe id) $ iforM (align curState newVals) $ \k -> \case

224+ These ((_, (start, end)), _) Nothing -> do -- Deleting child

225+ liftIO $ deleteBetweenInclusive start end

226+ return Nothing

227+ These ((_, (start, end)), _) (Just v) -> do -- Replacing existing child

228+ liftIO $ deleteBetweenExclusive start end

229+ Just df <- liftIO $ documentCreateDocumentFragment doc

230+ s <- buildChild df k v

231+ Just p <- liftIO $ nodeGetParentNode end

232+ liftIO $ nodeInsertBefore p (Just df) (Just end)

233+ return $ Just s

234+ That Nothing -> return Nothing -- Deleting non-existent child

235+ That (Just v) -> do -- Creating new child

236+ Just df <- liftIO $ documentCreateDocumentFragment doc

237+ s <- buildChild df k v

238+ let placeholder = case Map.lookupGT k curState of

239+ Nothing -> endPlaceholder

240+ Just (_, ((_, (start, _)), _)) -> start

241+ Just p <- liftIO $ nodeGetParentNode placeholder

242+ liftIO $ nodeInsertBefore p (Just df) (Just placeholder)

243+ return $ Just s

244+ This state -> do -- No change

245+ return $ Just state

246+ liftIO $ putStrLn "Triggering newChildren"

247+ liftIO $ putStrLn . ("newChildrenTriggerRef is Just? " <>) . show . isJust =<< readRef newChildrenTriggerRef

248+ runFrameWithTriggerRef newChildrenTriggerRef newState

249+ liftIO $ putStrLn "Triggering newChildren done"

250+ holdDyn Map.empty $ fmap (fmap (fst . fst)) newChildren

251+

200252selectViewListWithKey_ :: forall t m k v a. (MonadWidget t m, Ord k) => Dynamic t k -> Dynamic t (Map k v) -> (k -> Dynamic t v -> Dynamic t Bool -> m (Event t a)) -> m (Event t k)

201253selectViewListWithKey_ selection vals mkChild = do

202254 let selectionDemux = demux selection -- For good performance, this value must be shared across all children