git.iko.soy/patch
on 9cc8f7b help sign in
patch/src/Reflex/Adjustable/Class.hs
166 lines 11 kB history raw
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE RankNTypes #-}
3{-# LANGUAGE LambdaCase #-}
4{-# LANGUAGE RecursiveDo #-}
5{-# LANGUAGE ScopedTypeVariables #-}
6{-# LANGUAGE MultiParamTypeClasses #-}
7{-# LANGUAGE FunctionalDependencies #-}
8{-# LANGUAGE FlexibleInstances #-}
9{-# LANGUAGE TypeFamilies #-}
10{-# LANGUAGE UndecidableInstances #-}
11#ifdef USE_REFLEX_OPTIMIZER
12{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
13#endif
14module Reflex.Adjustable.Class
15 (
16 -- * The Adjustable typeclass
17 Adjustable(..)
18 , sequenceDMapWithAdjust
19 , sequenceDMapWithAdjustWithMove
20 , mapMapWithAdjustWithMove
21 -- * Widgets on Collections
22 , listHoldWithKey
23 , listWithKey
24 , listWithKey'
25 , listWithKeyShallowDiff
26 , listViewWithKey
27 , selectViewListWithKey
28 , selectViewListWithKey_
29 -- * List Utils
30 , list
31 , simpleList
32 ) where
34import Control.Monad.Identity hiding (forM, forM_, mapM, mapM_, sequence, sequence_)
35import Control.Monad.Reader hiding (forM, forM_, mapM, mapM_, sequence, sequence_)
36import Data.Align
37import Data.Map (Map)
38import qualified Data.Map as Map
39import Data.Dependent.Map (DMap, GCompare (..))
40import Data.Functor.Constant
41import Data.Functor.Misc
42import Data.Map.Misc
43import Data.These
45import Reflex.Class
46import Reflex.Dynamic
47import Reflex.PostBuild.Class
49-- | A 'Monad' that supports adjustment over time. After an action has been
50-- run, if the given events fire, it will adjust itself so that its net effect
51-- is as though it had originally been run with the new value. Note that there
52-- is some issue here with persistent side-effects: obviously, IO (and some
53-- other side-effects) cannot be undone, so it is up to the instance implementer
54-- to determine what the best meaning for this class is in such cases.
55class (Reflex t, Monad m) => Adjustable t m | m -> t where
56 runWithReplace :: m a -> Event t (m b) -> m (a, Event t b)
57 traverseIntMapWithKeyWithAdjust :: (IntMap.Key -> v -> m v') -> IntMap v -> Event t (PatchIntMap v) -> m (IntMap v', Event t (PatchIntMap v'))
58 traverseDMapWithKeyWithAdjust :: GCompare k => (forall a. k a -> v a -> m (v' a)) -> DMap k v -> Event t (PatchDMap k v) -> m (DMap k v', Event t (PatchDMap k v'))
59 traverseDMapWithKeyWithAdjustWithMove :: GCompare k => (forall a. k a -> v a -> m (v' a)) -> DMap k v -> Event t (PatchDMapWithMove k v) -> m (DMap k v', Event t (PatchDMapWithMove k v'))
61instance Adjustable t m => Adjustable t (ReaderT r m) where
62 runWithReplace a0 a' = do
63 r <- ask
64 lift $ runWithReplace (runReaderT a0 r) $ fmap (`runReaderT` r) a'
65 traverseIntMapWithKeyWithAdjust f dm0 dm' = do
66 r <- ask
67 lift $ traverseIntMapWithKeyWithAdjust (\k v -> runReaderT (f k v) r) dm0 dm'
68 traverseDMapWithKeyWithAdjust f dm0 dm' = do
69 r <- ask
70 lift $ traverseDMapWithKeyWithAdjust (\k v -> runReaderT (f k v) r) dm0 dm'
71 traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = do
72 r <- ask
73 lift $ traverseDMapWithKeyWithAdjustWithMove (\k v -> runReaderT (f k v) r) dm0 dm'
75sequenceDMapWithAdjust :: (GCompare k, Adjustable t m) => DMap k m -> Event t (PatchDMap k m) -> m (DMap k Identity, Event t (PatchDMap k Identity))
76sequenceDMapWithAdjust = traverseDMapWithKeyWithAdjust $ \_ -> fmap Identity
78sequenceDMapWithAdjustWithMove :: (GCompare k, Adjustable t m) => DMap k m -> Event t (PatchDMapWithMove k m) -> m (DMap k Identity, Event t (PatchDMapWithMove k Identity))
79sequenceDMapWithAdjustWithMove = traverseDMapWithKeyWithAdjustWithMove $ \_ -> fmap Identity
81mapMapWithAdjustWithMove :: forall t m k v v'. (Adjustable t m, Ord k) => (k -> v -> m v') -> Map k v -> Event t (PatchMapWithMove k v) -> m (Map k v', Event t (PatchMapWithMove k v'))
82mapMapWithAdjustWithMove f m0 m' = do
83 (out0 :: DMap (Const2 k v) (Constant v'), out') <- traverseDMapWithKeyWithAdjustWithMove (\(Const2 k) (Identity v) -> Constant <$> f k v) (mapToDMap m0) (const2PatchDMapWithMoveWith Identity <$> m')
84 return (dmapToMapWith (\(Constant v') -> v') out0, patchDMapWithMoveToPatchMapWithMoveWith (\(Constant v') -> v') <$> out')
86listHoldWithKey :: 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))
87listHoldWithKey m0 m' f = do
88 let dm0 = mapWithFunctorToDMap $ Map.mapWithKey f m0
89 dm' = fmap (PatchDMap . mapWithFunctorToDMap . Map.mapWithKey (\k v -> ComposeMaybe $ fmap (f k) v)) m'
90 (a0, a') <- sequenceDMapWithAdjust dm0 dm'
91 fmap dmapToMap . incrementalToDynamic <$> holdIncremental a0 a' --TODO: Move the dmapToMap to the righthand side so it doesn't get fully redone every time
93--TODO: Something better than Dynamic t (Map k v) - we want something where the Events carry diffs, not the whole value
94listWithKey :: 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))
95listWithKey vals mkChild = do
96 postBuild <- getPostBuild
97 let childValChangedSelector = fanMap $ updated vals
98 -- We keep track of changes to children values in the mkChild function we pass to listHoldWithKey
99 -- The other changes we need to keep track of are child insertions and deletions. diffOnlyKeyChanges
100 -- keeps track of insertions and deletions but ignores value changes, since they're already accounted for.
101 diffOnlyKeyChanges olds news = flip Map.mapMaybe (align olds news) $ \case
102 This _ -> Just Nothing
103 These _ _ -> Nothing
104 That new -> Just $ Just new
105 rec sentVals :: Dynamic t (Map k v) <- foldDyn applyMap Map.empty changeVals
106 let changeVals :: Event t (Map k (Maybe v))
107 changeVals = attachWith diffOnlyKeyChanges (current sentVals) $ leftmost
108 [ updated vals
109 , 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
110 ]
111 listHoldWithKey Map.empty changeVals $ \k v ->
112 mkChild k =<< holdDyn v (select childValChangedSelector $ Const2 k)
114{-# DEPRECATED listWithKey' "listWithKey' has been renamed to listWithKeyShallowDiff; also, its behavior has changed to fix a bug where children were always rebuilt (never updated)" #-}
115listWithKey' :: (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))
116listWithKey' = listWithKeyShallowDiff
118-- | 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.
119listWithKeyShallowDiff :: (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))
120listWithKeyShallowDiff initialVals valsChanged mkChild = do
121 let childValChangedSelector = fanMap $ fmap (Map.mapMaybe id) valsChanged
122 sentVals <- foldDyn applyMap Map.empty $ fmap (fmap void) valsChanged
123 let relevantPatch patch _ = case patch of
124 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
125 Just _ -> Nothing -- We don't want to let spurious re-creations of items through
126 listHoldWithKey initialVals (attachWith (flip (Map.differenceWith relevantPatch)) (current sentVals) valsChanged) $ \k v ->
127 mkChild k v $ select childValChangedSelector $ Const2 k
129--TODO: Something better than Dynamic t (Map k v) - we want something where the Events carry diffs, not the whole value
130-- | Create a dynamically-changing set of Event-valued widgets.
131-- 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'.
132listViewWithKey :: (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))
133listViewWithKey vals mkChild = switch . fmap mergeMap <$> listViewWithKey' vals mkChild
135listViewWithKey' :: (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))
136listViewWithKey' vals mkChild = current <$> listWithKey vals mkChild
138-- | Create a dynamically-changing set of widgets, one of which is selected at any time.
139selectViewListWithKey :: forall t m k v a. (Adjustable t m, Ord k, PostBuild t m, MonadHold t m, MonadFix m)
140 => Dynamic t k -- ^ Current selection key
141 -> Dynamic t (Map k v) -- ^ Dynamic key/value map
142 -> (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
143 -> m (Event t (k, a)) -- ^ Event that fires when any child's return Event fires. Contains key of an arbitrary firing widget.
144selectViewListWithKey selection vals mkChild = do
145 let selectionDemux = demux selection -- For good performance, this value must be shared across all children
146 selectChild <- listWithKey vals $ \k v -> do
147 let selected = demuxed selectionDemux k
148 selectSelf <- mkChild k v selected
149 return $ fmap ((,) k) selectSelf
150 return $ switchPromptlyDyn $ leftmost . Map.elems <$> selectChild
152selectViewListWithKey_ :: forall t m k v a. (Adjustable t m, Ord k, PostBuild t m, MonadHold t m, MonadFix m)
153 => Dynamic t k -- ^ Current selection key
154 -> Dynamic t (Map k v) -- ^ Dynamic key/value map
155 -> (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
156 -> m (Event t k) -- ^ Event that fires when any child's return Event fires. Contains key of an arbitrary firing widget.
157selectViewListWithKey_ selection vals mkChild = fmap fst <$> selectViewListWithKey selection vals mkChild
159-- | Create a dynamically-changing set of widgets from a Dynamic key/value map.
160-- Unlike the 'withKey' variants, the child widgets are insensitive to which key they're associated with.
161list :: (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))
162list dm mkChild = listWithKey dm (\_ dv -> mkChild dv)
164-- | Create a dynamically-changing set of widgets from a Dynamic list.
165simpleList :: (Adjustable t m, MonadHold t m, PostBuild t m, MonadFix m) => Dynamic t [v] -> (Dynamic t v -> m a) -> m (Dynamic t [a])
166simpleList xs mkChild = fmap (fmap (map snd . Map.toList)) $ flip list mkChild $ fmap (Map.fromList . zip [(1::Int)..]) xs