@@ -2,6 +2,7 @@
22{-# LANGUAGE ConstraintKinds #-}
33{-# LANGUAGE FlexibleInstances #-}
44{-# LANGUAGE FunctionalDependencies #-}
5+{-# LANGUAGE LambdaCase #-}
56{-# LANGUAGE MultiParamTypeClasses #-}
67{-# LANGUAGE RankNTypes #-}
78{-# LANGUAGE ScopedTypeVariables #-}
@@ -24,6 +25,7 @@ module Reflex.Adjustable.Class
2425import Control.Monad.Identity
2526import Control.Monad.Reader
2627import Data.Dependent.Map (DMap, GCompare (..))
28+import qualified Data.Dependent.Map as DMap
2729import Data.Functor.Constant
2830import Data.Functor.Misc
2931import Data.IntMap.Strict (IntMap)
@@ -31,6 +33,7 @@ import qualified Data.IntMap.Strict as IntMap
3133import Data.Map (Map)
3234
3335import Reflex.Class
36+import Reflex.Patch.DMapWithMove
3437
3538-- | A 'Monad' that supports adjustment over time. After an action has been
3639-- run, if the given events fire, it will adjust itself so that its net effect
@@ -39,10 +42,43 @@ import Reflex.Class
3942-- other side-effects) cannot be undone, so it is up to the instance implementer
4043-- to determine what the best meaning for this class is in such cases.
4144class (Reflex t, Monad m) => Adjustable t m | m -> t where
42− runWithReplace :: m a -> Event t (m b) -> m (a, Event t b)
43− traverseIntMapWithKeyWithAdjust :: (IntMap.Key -> v -> m v') -> IntMap v -> Event t (PatchIntMap v) -> m (IntMap v', Event t (PatchIntMap v'))
44− 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'))
45− 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'))
45+ runWithReplace
46+ :: m a
47+ -> Event t (m b)
48+ -> m (a, Event t b)
49+
50+ traverseIntMapWithKeyWithAdjust
51+ :: (IntMap.Key -> v -> m v')
52+ -> IntMap v
53+ -> Event t (PatchIntMap v)
54+ -> m (IntMap v', Event t (PatchIntMap v'))
55+
56+ traverseDMapWithKeyWithAdjust
57+ :: GCompare k
58+ => (forall a. k a -> v a -> m (v' a))
59+ -> DMap k v
60+ -> Event t (PatchDMap k v)
61+ -> m (DMap k v', Event t (PatchDMap k v'))
62+ {-# INLINABLE traverseDMapWithKeyWithAdjust #-}
63+ traverseDMapWithKeyWithAdjust f dm0 dm' = fmap (fmap (fmap fromPatchWithMove)) $
64+ traverseDMapWithKeyWithAdjustWithMove f dm0 $ fmap toPatchWithMove dm'
65+ where
66+ toPatchWithMove (PatchDMap m) = PatchDMapWithMove $ DMap.map toNodeInfoWithMove m
67+ toNodeInfoWithMove = \case
68+ ComposeMaybe (Just v) -> NodeInfo (From_Insert v) $ ComposeMaybe Nothing
69+ ComposeMaybe Nothing -> NodeInfo From_Delete $ ComposeMaybe Nothing
70+ fromPatchWithMove (PatchDMapWithMove m) = PatchDMap $ DMap.map fromNodeInfoWithMove m
71+ fromNodeInfoWithMove (NodeInfo from _) = ComposeMaybe $ case from of
72+ From_Insert v -> Just v
73+ From_Delete -> Nothing
74+ From_Move _ -> error "traverseDMapWithKeyWithAdjust: implementation of traverseDMapWithKeyWithAdjustWithMove inserted spurious move"
75+
76+ traverseDMapWithKeyWithAdjustWithMove
77+ :: GCompare k
78+ => (forall a. k a -> v a -> m (v' a))
79+ -> DMap k v
80+ -> Event t (PatchDMapWithMove k v)
81+ -> m (DMap k v', Event t (PatchDMapWithMove k v'))
4682
4783instance Adjustable t m => Adjustable t (ReaderT r m) where
4884 runWithReplace a0 a' = do