8662208 · reflex · git.iko.soy

git.iko.soy/reflex

on develop help sign in

A couple of improvements relating to Patch*WithMove

8662208Ryan Trinkle10 years ago

src/Reflex/Class.hs+7

compare with develop

unifiedsplit

@@ -98,6 +98,7 @@ module Reflex.Class

98 , MonadAdjust (..)

99 , sequenceDMapWithAdjust

100 , sequenceDMapWithAdjustWithMove

101+ , mapMapWithAdjustWithMove

101 -- * Deprecated functions

102 -- * Deprecated functions

102 , appendEvents

103 , appendEvents

103 , onceE

104 , onceE

@@ -160,6 +161,7 @@ import Data.Either

160import Data.Foldable

161import Data.Foldable

161import Data.Functor.Bind hiding (join)

162import Data.Functor.Bind hiding (join)

162import qualified Data.Functor.Bind as Bind

163import qualified Data.Functor.Bind as Bind

164+import Data.Functor.Constant

163import Data.Functor.Misc

165import Data.Functor.Misc

164import Data.Functor.Plus

166import Data.Functor.Plus

165import Data.List.NonEmpty (NonEmpty (..))

167import Data.List.NonEmpty (NonEmpty (..))

@@ -939,6 +941,11 @@ sequenceDMapWithAdjust = traverseDMapWithKeyWithAdjust $ \_ -> fmap Identity

939sequenceDMapWithAdjustWithMove :: (GCompare k, MonadAdjust t m) => DMap k m -> Event t (PatchDMapWithMove k m) -> m (DMap k Identity, Event t (PatchDMapWithMove k Identity))

941sequenceDMapWithAdjustWithMove :: (GCompare k, MonadAdjust t m) => DMap k m -> Event t (PatchDMapWithMove k m) -> m (DMap k Identity, Event t (PatchDMapWithMove k Identity))

940sequenceDMapWithAdjustWithMove = traverseDMapWithKeyWithAdjustWithMove $ \_ -> fmap Identity

942sequenceDMapWithAdjustWithMove = traverseDMapWithKeyWithAdjustWithMove $ \_ -> fmap Identity

941

943

944+mapMapWithAdjustWithMove :: forall t m k v v'. (MonadAdjust 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'))

945+mapMapWithAdjustWithMove f m0 m' = do

946+ (out0 :: DMap (Const2 k v) (Constant v'), out') <- traverseDMapWithKeyWithAdjustWithMove (\(Const2 k) (Identity v) -> Constant <$> f k v) (mapToDMap m0) (const2PatchDMapWithMoveWith Identity <$> m')

947+ return (dmapToMapWith (\(Constant v') -> v') out0, patchDMapWithMoveToPatchMapWithMoveWith (\(Constant v') -> v') <$> out')

948+

942------------------

949------------------

943-- Cheap Functions

950-- Cheap Functions

944------------------

951------------------

src/Reflex/Patch.hs+51−6

@@ -4,6 +4,7 @@

4{-# LANGUAGE DeriveFoldable #-}

5{-# LANGUAGE DeriveFunctor #-}

6{-# LANGUAGE DeriveTraversable #-}

7+{-# LANGUAGE FlexibleContexts #-}

7{-# LANGUAGE GADTs #-}

8{-# LANGUAGE GADTs #-}

8{-# LANGUAGE GeneralizedNewtypeDeriving #-}

9{-# LANGUAGE GeneralizedNewtypeDeriving #-}

9{-# LANGUAGE LambdaCase #-}

10{-# LANGUAGE LambdaCase #-}

@@ -33,10 +34,12 @@ module Reflex.Patch

33 , patchMapWithMoveNewElements

34 , patchMapWithMoveNewElements

34 , MapEdit (..)

35 , MapEdit (..)

35 , mapEditMoved

36 , mapEditMoved

37+ , mapEditSetMoved

36 , PatchDMapWithMove

38 , PatchDMapWithMove

37 , unPatchDMapWithMove

39 , unPatchDMapWithMove

38 , unsafePatchDMapWithMove

40 , unsafePatchDMapWithMove

39 , patchThatSortsMapWith

41 , patchThatSortsMapWith

42+ , patchThatChangesAndSortsMapWith

40 , mapPatchDMapWithMove

43 , mapPatchDMapWithMove

41 , traversePatchDMapWithMove

44 , traversePatchDMapWithMove

42 , traversePatchDMapWithMoveWithKey

45 , traversePatchDMapWithMoveWithKey

@@ -51,9 +54,12 @@ module Reflex.Patch

51 , knownInvalidPatchMapWithMove

54 , knownInvalidPatchMapWithMove

52 ) where

55 ) where

57+import Control.Arrow

54import Control.Monad.Identity

58import Control.Monad.Identity

59+import Control.Monad.State

55import Data.Dependent.Map (DMap, DSum (..), GCompare (..))

60import Data.Dependent.Map (DMap, DSum (..), GCompare (..))

56import qualified Data.Dependent.Map as DMap

61import qualified Data.Dependent.Map as DMap

62+import Data.Foldable

57import Data.Function

63import Data.Function

58import Data.Functor.Constant

64import Data.Functor.Constant

59import Data.Functor.Misc

65import Data.Functor.Misc

@@ -62,8 +68,11 @@ import Data.Map (Map)

62import qualified Data.Map as Map

68import qualified Data.Map as Map

63import Data.Maybe

69import Data.Maybe

64import Data.Semigroup (Semigroup (..), stimesIdempotentMonoid, (<>))

70import Data.Semigroup (Semigroup (..), stimesIdempotentMonoid, (<>))

71+import Data.Set (Set)

72+import qualified Data.Set as Set

65import Data.Some (Some)

73import Data.Some (Some)

66import qualified Data.Some as Some

74import qualified Data.Some as Some

75+import Data.Tuple

68-- | A 'Patch' type represents a kind of change made to a datastructure.

77-- | A 'Patch' type represents a kind of change made to a datastructure.

69class Patch p where

78class Patch p where

@@ -178,7 +187,7 @@ data MapEdit k v

178 = MapEdit_Insert Bool v -- ^ Insert the given value here

187 = MapEdit_Insert Bool v -- ^ Insert the given value here

179 | MapEdit_Delete Bool -- ^ Delete the existing value, if any, from here

188 | MapEdit_Delete Bool -- ^ Delete the existing value, if any, from here

180 | MapEdit_Move Bool k -- ^ Move the value here from the given key

189 | 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)

182

191

183mapEditMoved :: MapEdit k v -> Bool

192mapEditMoved :: MapEdit k v -> Bool

184mapEditMoved = \case

193mapEditMoved = \case

@@ -186,12 +195,18 @@ mapEditMoved = \case

186 MapEdit_Delete moved -> moved

195 MapEdit_Delete moved -> moved

187 MapEdit_Move moved _ -> moved

196 MapEdit_Move moved _ -> moved

188

197

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+

189-- | Patch a DMap with additions, deletions, and moves.

204-- | Patch a DMap with additions, deletions, and moves.

190-- Invariants:

205-- Invariants:

191-- * The same source key may not be moved to two destination keys.

206-- * The same source key may not be moved to two destination keys.

192-- * Any key that is the source of a Move must also be edited

207-- * Any key that is the source of a Move must also be edited

193-- (otherwise, the Move would duplicate it)

208-- (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)

195

210

196unPatchMapWithMove :: PatchMapWithMove k v -> Map k (MapEdit k v)

211unPatchMapWithMove :: PatchMapWithMove k v -> Map k (MapEdit k v)

197unPatchMapWithMove (PatchMapWithMove p) = p

212unPatchMapWithMove (PatchMapWithMove p) = p

@@ -209,8 +224,8 @@ instance Ord k => Patch (PatchMapWithMove k v) where

209 MapEdit_Move _ k -> Map.lookup k old

224 MapEdit_Move _ k -> Map.lookup k old

210 MapEdit_Delete _ -> Nothing

225 MapEdit_Delete _ -> Nothing

211 deletions = flip Map.mapMaybeWithKey p $ const $ \case

226 deletions = flip Map.mapMaybeWithKey p $ const $ \case

212− MapEdit_Delete _ -> Nothing

227+ MapEdit_Delete _ -> Just ()

213− _ -> Just ()

228+ _ -> Nothing

214

229

215-- | Returns all the new elements that will be added to the 'Map'

230-- | Returns all the new elements that will be added to the 'Map'

216patchMapWithMoveNewElements :: PatchMapWithMove k v -> [v]

231patchMapWithMoveNewElements :: PatchMapWithMove k v -> [v]

@@ -259,6 +274,36 @@ patchThatSortsMapWith cmp m = PatchMapWithMove $ Map.fromList $ catMaybes $ zipW

259 then Nothing

274 then Nothing

260 else Just (to, MapEdit_Move True from)

275 else Just (to, MapEdit_Move True from)

261

276

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+

262data DMapEdit (k :: a -> *) (v :: a -> *) :: a -> * where

307data DMapEdit (k :: a -> *) (v :: a -> *) :: a -> * where

263 -- | Insert the given value here

308 -- | Insert the given value here

264 DMapEdit_Insert :: Bool -> v a -> DMapEdit k v a

309 DMapEdit_Insert :: Bool -> v a -> DMapEdit k v a

@@ -339,5 +384,5 @@ instance GCompare k => Patch (PatchDMapWithMove k v) where

339 deletions = DMap.mapMaybeWithKey deleteFunc p

384 deletions = DMap.mapMaybeWithKey deleteFunc p

340 deleteFunc :: forall a. k a -> DMapEdit k v a -> Maybe (Constant () a)

385 deleteFunc :: forall a. k a -> DMapEdit k v a -> Maybe (Constant () a)

341 deleteFunc _ = \case

386 deleteFunc _ = \case

342− DMapEdit_Delete _ -> Nothing

387+ DMapEdit_Delete _ -> Just $ Constant ()

343− _ -> Just $ Constant ()

388+ _ -> Nothing