git.iko.soy/patch
on 03387bd help sign in
patch/src/Reflex/Collection.hs
121 lines 7.8 kB history raw
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE FlexibleInstances #-}
3{-# LANGUAGE LambdaCase #-}
4{-# LANGUAGE MultiParamTypeClasses #-}
5{-# LANGUAGE RankNTypes #-}
6{-# LANGUAGE RecursiveDo #-}
7{-# LANGUAGE ScopedTypeVariables #-}
8{-# LANGUAGE TypeFamilies #-}
9{-# LANGUAGE UndecidableInstances #-}
10#ifdef USE_REFLEX_OPTIMIZER
11{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
12#endif
13module Reflex.Collection
14 (
15 -- * Widgets on Collections
16 listHoldWithKey
17 , listWithKey
18 , listWithKey'
19 , listWithKeyShallowDiff
20 , listViewWithKey
21 , selectViewListWithKey
22 , selectViewListWithKey_
23 -- * List Utils
24 , list
25 , simpleList
26 ) where
28import Control.Monad.Identity
29import Data.Align
30import Data.Functor.Misc
31import Data.Map (Map)
32import qualified Data.Map as Map
33import Data.Map.Misc
34import Data.These
36import Reflex.Class
37import Reflex.Adjustable.Class
38import Reflex.Dynamic
39import Reflex.PostBuild.Class
41listHoldWithKey :: forall t m k v a. (Ord k, Adjustable t m, MonadHold t m) => Map k v -> Event t (Map k (Maybe v)) -> (k -> v -> m a) -> m (Dynamic t (Map k a))
42listHoldWithKey m0 m' f = do
43 let dm0 = mapWithFunctorToDMap $ Map.mapWithKey f m0
44 dm' = fmap (PatchDMap . mapWithFunctorToDMap . Map.mapWithKey (\k v -> ComposeMaybe $ fmap (f k) v)) m'
45 (a0, a') <- sequenceDMapWithAdjust dm0 dm'
46 fmap dmapToMap . incrementalToDynamic <$> holdIncremental a0 a' --TODO: Move the dmapToMap to the righthand side so it doesn't get fully redone every time
48--TODO: Something better than Dynamic t (Map k v) - we want something where the Events carry diffs, not the whole value
49listWithKey :: forall t k v m a. (Ord k, Adjustable 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))
50listWithKey vals mkChild = do
51 postBuild <- getPostBuild
52 let childValChangedSelector = fanMap $ updated vals
53 -- We keep track of changes to children values in the mkChild function we pass to listHoldWithKey
54 -- The other changes we need to keep track of are child insertions and deletions. diffOnlyKeyChanges
55 -- keeps track of insertions and deletions but ignores value changes, since they're already accounted for.
56 diffOnlyKeyChanges olds news = flip Map.mapMaybe (align olds news) $ \case
57 This _ -> Just Nothing
58 These _ _ -> Nothing
59 That new -> Just $ Just new
60 rec sentVals :: Dynamic t (Map k v) <- foldDyn applyMap Map.empty changeVals
61 let changeVals :: Event t (Map k (Maybe v))
62 changeVals = attachWith diffOnlyKeyChanges (current sentVals) $ leftmost
63 [ updated vals
64 , tag (current vals) postBuild --TODO: This should probably be added to the attachWith, not to the updated; if we were using diffMap instead of diffMapNoEq, I think it might not work
65 ]
66 listHoldWithKey Map.empty changeVals $ \k v ->
67 mkChild k =<< holdDyn v (select childValChangedSelector $ Const2 k)
69{-# DEPRECATED listWithKey' "listWithKey' has been renamed to listWithKeyShallowDiff; also, its behavior has changed to fix a bug where children were always rebuilt (never updated)" #-}
70listWithKey' :: (Ord k, Adjustable 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))
71listWithKey' = listWithKeyShallowDiff
73-- | Display the given map of items (in key order) using the builder function provided, and update it with the given event. 'Nothing' update entries will delete the corresponding children, and 'Just' entries will create them if they do not exist or send an update event to them if they do.
74listWithKeyShallowDiff :: (Ord k, Adjustable 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))
75listWithKeyShallowDiff initialVals valsChanged mkChild = do
76 let childValChangedSelector = fanMap $ fmap (Map.mapMaybe id) valsChanged
77 sentVals <- foldDyn applyMap (void initialVals) $ fmap (fmap void) valsChanged
78 let relevantPatch patch _ = case patch of
79 Nothing -> Just Nothing -- Even if we let a Nothing through when the element doesn't already exist, this doesn't cause a problem because it is ignored
80 Just _ -> Nothing -- We don't want to let spurious re-creations of items through
81 listHoldWithKey initialVals (attachWith (flip (Map.differenceWith relevantPatch)) (current sentVals) valsChanged) $ \k v ->
82 mkChild k v $ select childValChangedSelector $ Const2 k
84--TODO: Something better than Dynamic t (Map k v) - we want something where the Events carry diffs, not the whole value
85-- | Create a dynamically-changing set of Event-valued widgets.
86-- 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'.
87listViewWithKey :: (Ord k, Adjustable 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))
88listViewWithKey vals mkChild = switch . fmap mergeMap <$> listViewWithKey' vals mkChild
90listViewWithKey' :: (Ord k, Adjustable 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))
91listViewWithKey' vals mkChild = current <$> listWithKey vals mkChild
93-- | Create a dynamically-changing set of widgets, one of which is selected at any time.
94selectViewListWithKey :: forall t m k v a. (Adjustable t m, Ord k, PostBuild t m, MonadHold t m, MonadFix m)
95 => Dynamic t k -- ^ Current selection key
96 -> Dynamic t (Map k v) -- ^ Dynamic key/value map
97 -> (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
98 -> m (Event t (k, a)) -- ^ Event that fires when any child's return Event fires. Contains key of an arbitrary firing widget.
99selectViewListWithKey selection vals mkChild = do
100 let selectionDemux = demux selection -- For good performance, this value must be shared across all children
101 selectChild <- listWithKey vals $ \k v -> do
102 let selected = demuxed selectionDemux k
103 selectSelf <- mkChild k v selected
104 return $ fmap ((,) k) selectSelf
105 return $ switchPromptlyDyn $ leftmost . Map.elems <$> selectChild
107selectViewListWithKey_ :: forall t m k v a. (Adjustable t m, Ord k, PostBuild t m, MonadHold t m, MonadFix m)
108 => Dynamic t k -- ^ Current selection key
109 -> Dynamic t (Map k v) -- ^ Dynamic key/value map
110 -> (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
111 -> m (Event t k) -- ^ Event that fires when any child's return Event fires. Contains key of an arbitrary firing widget.
112selectViewListWithKey_ selection vals mkChild = fmap fst <$> selectViewListWithKey selection vals mkChild
114-- | Create a dynamically-changing set of widgets from a Dynamic key/value map.
115-- Unlike the 'withKey' variants, the child widgets are insensitive to which key they're associated with.
116list :: (Ord k, Adjustable 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))
117list dm mkChild = listWithKey dm (\_ dv -> mkChild dv)
119-- | Create a dynamically-changing set of widgets from a Dynamic list.
120simpleList :: (Adjustable t m, MonadHold t m, PostBuild t m, MonadFix m) => Dynamic t [v] -> (Dynamic t v -> m a) -> m (Dynamic t [a])
121simpleList xs mkChild = fmap (fmap (map snd . Map.toList)) $ flip list mkChild $ fmap (Map.fromList . zip [(1::Int)..]) xs