@@ -2,6 +2,7 @@
2{-# LANGUAGE ConstraintKinds #-}
2{-# LANGUAGE ConstraintKinds #-}
3{-# LANGUAGE FlexibleInstances #-}
3{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE FunctionalDependencies #-}
4{-# LANGUAGE FunctionalDependencies #-}
5+{-# LANGUAGE LambdaCase #-}
5{-# LANGUAGE MultiParamTypeClasses #-}
6{-# LANGUAGE MultiParamTypeClasses #-}
6{-# LANGUAGE RankNTypes #-}
7{-# LANGUAGE RankNTypes #-}
7{-# LANGUAGE ScopedTypeVariables #-}
8{-# LANGUAGE ScopedTypeVariables #-}
@@ -24,6 +25,7 @@ module Reflex.Adjustable.Class
24import Control.Monad.Identity
25import Control.Monad.Identity
25import Control.Monad.Reader
26import Control.Monad.Reader
26import Data.Dependent.Map (DMap, GCompare (..))
27import Data.Dependent.Map (DMap, GCompare (..))
28+import qualified Data.Dependent.Map as DMap
27import Data.Functor.Constant
29import Data.Functor.Constant
28import Data.Functor.Misc
30import Data.Functor.Misc
29import Data.IntMap.Strict (IntMap)
31import Data.IntMap.Strict (IntMap)
@@ -31,6 +33,7 @@ import qualified Data.IntMap.Strict as IntMap
31import Data.Map (Map)
33import Data.Map (Map)
33import Reflex.Class
35import Reflex.Class
36+import Reflex.Patch.DMapWithMove
35-- | A 'Monad' that supports adjustment over time. After an action has been
38-- | A 'Monad' that supports adjustment over time. After an action has been
36-- run, if the given events fire, it will adjust itself so that its net effect
39-- run, if the given events fire, it will adjust itself so that its net effect
@@ -39,10 +42,43 @@ import Reflex.Class
39-- other side-effects) cannot be undone, so it is up to the instance implementer
42-- other side-effects) cannot be undone, so it is up to the instance implementer
40-- to determine what the best meaning for this class is in such cases.
43-- to determine what the best meaning for this class is in such cases.
41class (Reflex t, Monad m) => Adjustable t m | m -> t where
44class (Reflex t, Monad m) => Adjustable t m | m -> t where
42− runWithReplace :: m a -> Event t (m b) -> m (a, Event t b)
45+ runWithReplace
43− traverseIntMapWithKeyWithAdjust :: (IntMap.Key -> v -> m v') -> IntMap v -> Event t (PatchIntMap v) -> m (IntMap v', Event t (PatchIntMap v'))
50+ traverseIntMapWithKeyWithAdjust
51+ :: (IntMap.Key -> v -> m v')
53+ -> Event t (PatchIntMap v)
54+ -> 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'))
56+ traverseDMapWithKeyWithAdjust
58+ => (forall a. k a -> v a -> m (v' a))
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'
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"
76+ traverseDMapWithKeyWithAdjustWithMove
78+ => (forall a. k a -> v a -> m (v' a))
80+ -> Event t (PatchDMapWithMove 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'))
81+ -> m (DMap k v', Event t (PatchDMapWithMove k v'))
47instance Adjustable t m => Adjustable t (ReaderT r m) where
83instance Adjustable t m => Adjustable t (ReaderT r m) where
48 runWithReplace a0 a' = do
84 runWithReplace a0 a' = do