@@ -4,6 +4,7 @@
44{-# LANGUAGE DeriveFoldable #-}
55{-# LANGUAGE DeriveFunctor #-}
66{-# LANGUAGE DeriveTraversable #-}
7+{-# LANGUAGE FlexibleContexts #-}
78{-# LANGUAGE GADTs #-}
89{-# LANGUAGE GeneralizedNewtypeDeriving #-}
910{-# LANGUAGE LambdaCase #-}
@@ -33,10 +34,12 @@ module Reflex.Patch
3334 , patchMapWithMoveNewElements
3435 , MapEdit (..)
3536 , mapEditMoved
37+ , mapEditSetMoved
3638 , PatchDMapWithMove
3739 , unPatchDMapWithMove
3840 , unsafePatchDMapWithMove
3941 , patchThatSortsMapWith
42+ , patchThatChangesAndSortsMapWith
4043 , mapPatchDMapWithMove
4144 , traversePatchDMapWithMove
4245 , traversePatchDMapWithMoveWithKey
@@ -51,9 +54,12 @@ module Reflex.Patch
5154 , knownInvalidPatchMapWithMove
5255 ) where
5356
57+import Control.Arrow
5458import Control.Monad.Identity
59+import Control.Monad.State
5560import Data.Dependent.Map (DMap, DSum (..), GCompare (..))
5661import qualified Data.Dependent.Map as DMap
62+import Data.Foldable
5763import Data.Function
5864import Data.Functor.Constant
5965import Data.Functor.Misc
@@ -62,8 +68,11 @@ import Data.Map (Map)
6268import qualified Data.Map as Map
6369import Data.Maybe
6470import Data.Semigroup (Semigroup (..), stimesIdempotentMonoid, (<>))
71+import Data.Set (Set)
72+import qualified Data.Set as Set
6573import Data.Some (Some)
6674import qualified Data.Some as Some
75+import Data.Tuple
6776
6877-- | A 'Patch' type represents a kind of change made to a datastructure.
6978class Patch p where
@@ -178,7 +187,7 @@ data MapEdit k v
178187 = MapEdit_Insert Bool v -- ^ Insert the given value here
179188 | MapEdit_Delete Bool -- ^ Delete the existing value, if any, from here
180189 | MapEdit_Move Bool k -- ^ Move the value here from the given key
181− deriving (Functor, Foldable, Traversable)
190+ deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable)
182191
183192mapEditMoved :: MapEdit k v -> Bool
184193mapEditMoved = \case
@@ -186,12 +195,18 @@ mapEditMoved = \case
186195 MapEdit_Delete moved -> moved
187196 MapEdit_Move moved _ -> moved
188197
198+mapEditSetMoved :: Bool -> MapEdit k v -> MapEdit k v
199+mapEditSetMoved moved = \case
200+ MapEdit_Insert _ v -> MapEdit_Insert moved v
201+ MapEdit_Delete _ -> MapEdit_Delete moved
202+ MapEdit_Move _ k -> MapEdit_Move moved k
203+
189204-- | Patch a DMap with additions, deletions, and moves.
190205-- Invariants:
191206-- * The same source key may not be moved to two destination keys.
192207-- * Any key that is the source of a Move must also be edited
193208-- (otherwise, the Move would duplicate it)
194−data PatchMapWithMove k v = PatchMapWithMove (Map k (MapEdit k v)) deriving (Functor, Foldable, Traversable)
209+data PatchMapWithMove k v = PatchMapWithMove (Map k (MapEdit k v)) deriving (Show, Eq, Ord, Functor, Foldable, Traversable)
195210
196211unPatchMapWithMove :: PatchMapWithMove k v -> Map k (MapEdit k v)
197212unPatchMapWithMove (PatchMapWithMove p) = p
@@ -209,8 +224,8 @@ instance Ord k => Patch (PatchMapWithMove k v) where
209224 MapEdit_Move _ k -> Map.lookup k old
210225 MapEdit_Delete _ -> Nothing
211226 deletions = flip Map.mapMaybeWithKey p $ const $ \case
212− MapEdit_Delete _ -> Nothing
213− _ -> Just ()
227+ MapEdit_Delete _ -> Just ()
228+ _ -> Nothing
214229
215230-- | Returns all the new elements that will be added to the 'Map'
216231patchMapWithMoveNewElements :: PatchMapWithMove k v -> [v]
@@ -259,6 +274,36 @@ patchThatSortsMapWith cmp m = PatchMapWithMove $ Map.fromList $ catMaybes $ zipW
259274 then Nothing
260275 else Just (to, MapEdit_Move True from)
261276
277+patchThatChangesAndSortsMapWith :: (Ord k, Ord v) => (v -> v -> Ordering) -> Map k v -> Map k v -> PatchMapWithMove k v
278+patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patch
279+ where oldByValue = Map.fromListWith Set.union $ swap . first Set.singleton <$> Map.toList oldByIndex
280+ newList = Map.toList newByIndexUnsorted
281+ newByIndex = Map.fromList $ zip (fst <$> newList) $ sortBy cmp $ snd <$> newList
282+ (insertsAndMoves, unusedValuesByValue) = flip runState oldByValue $ do
283+ let f k v = do
284+ remainingValues <- get
285+ let putRemainingKeys remainingKeys = put $ if Set.null remainingKeys
286+ then Map.delete v remainingValues
287+ else Map.insert v remainingKeys remainingValues
288+ case Map.lookup v remainingValues of
289+ Nothing -> return $ MapEdit_Insert True v -- There's no existing value we can take
290+ Just fromKs ->
291+ if k `Set.member` fromKs
292+ then do
293+ putRemainingKeys $ Set.delete k fromKs
294+ return $ MapEdit_Move True k -- There's an existing value, and it's here, so no patch necessary
295+ else do
296+ Just (fromK, remainingKeys) <- return $ Set.minView fromKs -- There's an existing value, but it's not here; move it here
297+ putRemainingKeys remainingKeys
298+ return $ MapEdit_Move True fromK
299+ Map.traverseWithKey f newByIndex
300+ unusedOldKeys = fold unusedValuesByValue
301+ pointlessMove k = \case
302+ MapEdit_Move _ k' | k == k' -> True
303+ _ -> False
304+ keyWasMoved k = k `Map.member` oldByIndex && not (k `Set.member` unusedOldKeys)
305+ patch = unsafePatchMapWithMove $ Map.filterWithKey (\k v -> not $ pointlessMove k v) $ Map.mergeWithKey (\k a _ -> Just $ mapEditSetMoved (keyWasMoved k) a) (Map.mapWithKey $ \k -> mapEditSetMoved $ keyWasMoved k) (Map.mapWithKey $ \k _ -> MapEdit_Delete $ keyWasMoved k) insertsAndMoves oldByIndex
306+
262307data DMapEdit (k :: a -> *) (v :: a -> *) :: a -> * where
263308 -- | Insert the given value here
264309 DMapEdit_Insert :: Bool -> v a -> DMapEdit k v a
@@ -339,5 +384,5 @@ instance GCompare k => Patch (PatchDMapWithMove k v) where
339384 deletions = DMap.mapMaybeWithKey deleteFunc p
340385 deleteFunc :: forall a. k a -> DMapEdit k v a -> Maybe (Constant () a)
341386 deleteFunc _ = \case
342− DMapEdit_Delete _ -> Nothing
343− _ -> Just $ Constant ()
387+ DMapEdit_Delete _ -> Just $ Constant ()
388+ _ -> Nothing