src/Data/Patch/MapWithPatchingMove.hs · patch

git.iko.soy/patch

on 1bfa6d6 help sign in

patch/src/Data/Patch/MapWithPatchingMove.hs

355 lines 17 kB history raw

1{-# LANGUAGE CPP #-}

2{-# LANGUAGE GeneralizedNewtypeDeriving #-}

3{-# LANGUAGE FlexibleContexts #-}

4{-# LANGUAGE FlexibleInstances #-}

5{-# LANGUAGE LambdaCase #-}

6{-# LANGUAGE MultiParamTypeClasses #-}

7{-# LANGUAGE PatternGuards #-}

8{-# LANGUAGE ScopedTypeVariables #-}

9{-# LANGUAGE StandaloneDeriving #-}

10{-# LANGUAGE TemplateHaskell #-}

11{-# LANGUAGE TypeFamilies #-}

12{-# LANGUAGE UndecidableInstances #-}

14-- | 'Patch'es on 'Map' that can insert, delete, and move values from one key to

15-- another

16module Data.Patch.MapWithPatchingMove where

18import Data.Patch.Class

20import Control.Arrow

21import Control.Lens.TH (makeWrapped)

22import Control.Monad.Trans.State

23import Data.Foldable

24import Data.Function

25import Data.List

26import Data.Map (Map)

27import qualified Data.Map as Map

28import Data.Maybe

29#if !MIN_VERSION_base(4,10,0)

30import Data.Semigroup (Semigroup (..))

31#endif

32import Data.Monoid.DecidablyEmpty

33import qualified Data.Set as Set

34import Data.These (These (..))

35import Data.Tuple

37-- | Patch a Map with additions, deletions, and moves. Invariant: If key @k1@

38-- is coming from @From_Move k2@, then key @k2@ should be going to @Just k1@,

39-- and vice versa. There should never be any unpaired From/To keys.

40newtype PatchMapWithPatchingMove k p = PatchMapWithPatchingMove

41 { -- | Extract the internal representation of the 'PatchMapWithPatchingMove'

42 unPatchMapWithPatchingMove :: Map k (NodeInfo k p)

43 }

45deriving instance (Show k, Show p, Show (PatchTarget p)) => Show (PatchMapWithPatchingMove k p)

46deriving instance (Ord k, Read k, Read p, Read (PatchTarget p)) => Read (PatchMapWithPatchingMove k p)

47deriving instance (Eq k, Eq p, Eq (PatchTarget p)) => Eq (PatchMapWithPatchingMove k p)

48deriving instance (Ord k, Ord p, Ord (PatchTarget p)) => Ord (PatchMapWithPatchingMove k p)

49deriving instance (Ord k, Monoid p, DecidablyEmpty p, Patch p) => DecidablyEmpty (PatchMapWithPatchingMove k p)

51-- | Holds the information about each key: where its new value should come from,

52-- and where its old value should go to

53data NodeInfo k p = NodeInfo

54 { _nodeInfo_from :: !(From k p)

55 -- ^ Where do we get the new value for this key?

56 , _nodeInfo_to :: !(To k)

57 -- ^ If the old value is being kept (i.e. moved rather than deleted or

58 -- replaced), where is it going?

59 }

60deriving instance (Show k, Show p, Show (PatchTarget p)) => Show (NodeInfo k p)

61deriving instance (Read k, Read p, Read (PatchTarget p)) => Read (NodeInfo k p)

62deriving instance (Eq k, Eq p, Eq (PatchTarget p)) => Eq (NodeInfo k p)

63deriving instance (Ord k, Ord p, Ord (PatchTarget p)) => Ord (NodeInfo k p)

65bitraverseNodeInfo

66 :: Applicative f

67 => (k0 -> f k1)

68 -> (p0 -> f p1)

69 -> (PatchTarget p0 -> f (PatchTarget p1))

70 -> NodeInfo k0 p0 -> f (NodeInfo k1 p1)

71bitraverseNodeInfo fk fp fpt (NodeInfo from to) = NodeInfo

72 <$> bitraverseFrom fk fp fpt from

73 <*> traverse fk to

75-- | Describe how a key's new value should be produced

76data From k p

77 = From_Insert (PatchTarget p) -- ^ Insert the given value here

78 | From_Delete -- ^ Delete the existing value, if any, from here

79 | From_Move !k !p -- ^ Move the value here from the given key, and apply the given patch

81bitraverseFrom

82 :: Applicative f

83 => (k0 -> f k1)

84 -> (p0 -> f p1)

85 -> (PatchTarget p0 -> f (PatchTarget p1))

86 -> From k0 p0 -> f (From k1 p1)

87bitraverseFrom fk fp fpt = \case

88 From_Insert pt -> From_Insert <$> fpt pt

89 From_Delete -> pure From_Delete

90 From_Move k p -> From_Move <$> fk k <*> fp p

92deriving instance (Show k, Show p, Show (PatchTarget p)) => Show (From k p)

93deriving instance (Read k, Read p, Read (PatchTarget p)) => Read (From k p)

94deriving instance (Eq k, Eq p, Eq (PatchTarget p)) => Eq (From k p)

95deriving instance (Ord k, Ord p, Ord (PatchTarget p)) => Ord (From k p)

97-- | Describe where a key's old value will go. If this is 'Just', that means

98-- the key's old value will be moved to the given other key; if it is 'Nothing',

99-- that means it will be deleted.

100type To = Maybe

101

102-- | Create a 'PatchMapWithPatchingMove', validating it

103patchMapWithPatchingMove

104 :: Ord k => Map k (NodeInfo k p) -> Maybe (PatchMapWithPatchingMove k p)

105patchMapWithPatchingMove m = if valid then Just $ PatchMapWithPatchingMove m else Nothing

106 where valid = forwardLinks == backwardLinks

107 forwardLinks = Map.mapMaybe _nodeInfo_to m

108 backwardLinks = Map.fromList $ catMaybes $ flip fmap (Map.toList m) $ \(to, p) ->

109 case _nodeInfo_from p of

110 From_Move from _ -> Just (from, to)

111 _ -> Nothing

112

113-- | Create a 'PatchMapWithPatchingMove' that inserts everything in the given 'Map'

114patchMapWithPatchingMoveInsertAll

115 :: Map k (PatchTarget p) -> PatchMapWithPatchingMove k p

116patchMapWithPatchingMoveInsertAll m = PatchMapWithPatchingMove $ flip fmap m $ \v -> NodeInfo

117 { _nodeInfo_from = From_Insert v

118 , _nodeInfo_to = Nothing

119 }

120

121-- | Make a @'PatchMapWithPatchingMove' k p@ which has the effect of inserting or replacing a value @v@ at the given key @k@, like 'Map.insert'.

122insertMapKey

123 :: k -> PatchTarget p -> PatchMapWithPatchingMove k p

124insertMapKey k v = PatchMapWithPatchingMove . Map.singleton k $ NodeInfo (From_Insert v) Nothing

125

126-- |Make a @'PatchMapWithPatchingMove' k p@ which has the effect of moving the value from the first key @k@ to the second key @k@, equivalent to:

127--

128-- @

129-- 'Map.delete' src (maybe map ('Map.insert' dst) (Map.lookup src map))

130-- @

131moveMapKey

132 :: (DecidablyEmpty p, Patch p) => Ord k => k -> k -> PatchMapWithPatchingMove k p

133moveMapKey src dst

134 | src == dst = mempty

135 | otherwise =

136 PatchMapWithPatchingMove $ Map.fromList

137 [ (dst, NodeInfo (From_Move src mempty) Nothing)

138 , (src, NodeInfo From_Delete (Just dst))

139 ]

140

141-- |Make a @'PatchMapWithPatchingMove' k p@ which has the effect of swapping two keys in the mapping, equivalent to:

142--

143-- @

144-- let aMay = Map.lookup a map

145-- bMay = Map.lookup b map

146-- in maybe id (Map.insert a) (bMay `mplus` aMay)

147-- . maybe id (Map.insert b) (aMay `mplus` bMay)

148-- . Map.delete a . Map.delete b $ map

149-- @

150swapMapKey

151 :: (DecidablyEmpty p, Patch p)

152 => Ord k => k -> k -> PatchMapWithPatchingMove k p

153swapMapKey src dst

154 | src == dst = mempty

155 | otherwise =

156 PatchMapWithPatchingMove $ Map.fromList

157 [ (dst, NodeInfo (From_Move src mempty) (Just src))

158 , (src, NodeInfo (From_Move dst mempty) (Just dst))

159 ]

160

161-- | Make a @'PatchMapWithPatchingMove' k v@ which has the effect of deleting a key in

162-- the mapping, equivalent to 'Map.delete'.

163deleteMapKey

164 :: k -> PatchMapWithPatchingMove k v

165deleteMapKey k = PatchMapWithPatchingMove . Map.singleton k $ NodeInfo From_Delete Nothing

166

167-- | Wrap a @'Map' k (NodeInfo k v)@ representing patch changes into a @'PatchMapWithPatchingMove' k v@, without checking any invariants.

168--

169-- __Warning:__ when using this function, you must ensure that the invariants of 'PatchMapWithPatchingMove' are preserved; they will not be checked.

170unsafePatchMapWithPatchingMove

171 :: Map k (NodeInfo k p) -> PatchMapWithPatchingMove k p

172unsafePatchMapWithPatchingMove = PatchMapWithPatchingMove

173

174-- | Apply the insertions, deletions, and moves to a given 'Map'

175instance (Ord k, Patch p) => Patch (PatchMapWithPatchingMove k p) where

176 type PatchTarget (PatchMapWithPatchingMove k p) = Map k (PatchTarget p)

177 -- TODO: return Nothing sometimes

178 -- Note: the strict application here is critical to ensuring that incremental

179 -- merges don't hold onto all their prerequisite events forever; can we make

180 -- this more robust?

181 apply (PatchMapWithPatchingMove m) old = Just $! insertions `Map.union` (old `Map.difference` deletions)

182 where insertions = flip Map.mapMaybeWithKey m $ \_ ni -> case _nodeInfo_from ni of

183 From_Insert v -> Just v

184 From_Move k p -> applyAlways p <$> Map.lookup k old

185 From_Delete -> Nothing

186 deletions = flip Map.mapMaybeWithKey m $ \_ ni -> case _nodeInfo_from ni of

187 From_Delete -> Just ()

188 _ -> Nothing

189

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

191patchMapWithPatchingMoveNewElements

192 :: PatchMapWithPatchingMove k p -> [PatchTarget p]

193patchMapWithPatchingMoveNewElements = Map.elems . patchMapWithPatchingMoveNewElementsMap

194

195-- | Return a @'Map' k v@ with all the inserts/updates from the given @'PatchMapWithPatchingMove' k v@.

196patchMapWithPatchingMoveNewElementsMap

197 :: PatchMapWithPatchingMove k p -> Map k (PatchTarget p)

198patchMapWithPatchingMoveNewElementsMap (PatchMapWithPatchingMove p) = Map.mapMaybe f p

199 where f ni = case _nodeInfo_from ni of

200 From_Insert v -> Just v

201 From_Move _ _ -> Nothing

202 From_Delete -> Nothing

203

204-- | Create a 'PatchMapWithPatchingMove' that, if applied to the given 'Map', will sort

205-- its values using the given ordering function. The set keys of the 'Map' is

206-- not changed.

207patchThatSortsMapWith

208 :: (Ord k, Monoid p)

209 => (PatchTarget p -> PatchTarget p -> Ordering)

210 -> Map k (PatchTarget p) -> PatchMapWithPatchingMove k p

211patchThatSortsMapWith cmp m = PatchMapWithPatchingMove $ Map.fromList $ catMaybes $ zipWith g unsorted sorted

212 where unsorted = Map.toList m

213 sorted = sortBy (cmp `on` snd) unsorted

214 f (to, _) (from, _) = if to == from then Nothing else

215 Just (from, to)

216 reverseMapping = Map.fromList $ catMaybes $ zipWith f unsorted sorted

217 g (to, _) (from, _) = if to == from then Nothing else

218 let Just movingTo = Map.lookup from reverseMapping

219 in Just (to, NodeInfo (From_Move from mempty) $ Just movingTo)

220

221-- | Create a 'PatchMapWithPatchingMove' that, if applied to the first 'Map' provided,

222-- will produce a 'Map' with the same values as the second 'Map' but with the

223-- values sorted with the given ordering function.

224patchThatChangesAndSortsMapWith

225 :: forall k p. (Ord k, Ord (PatchTarget p), Monoid p)

226 => (PatchTarget p -> PatchTarget p -> Ordering)

227 -> Map k (PatchTarget p) -> Map k (PatchTarget p) -> PatchMapWithPatchingMove k p

228patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patchThatChangesMap oldByIndex newByIndex

229 where newList = Map.toList newByIndexUnsorted

230 newByIndex = Map.fromList $ zip (fst <$> newList) $ sortBy cmp $ snd <$> newList

231

232-- | Create a 'PatchMapWithPatchingMove' that, if applied to the first 'Map' provided,

233-- will produce the second 'Map'.

234patchThatChangesMap

235 :: (Ord k, Ord (PatchTarget p), Monoid p)

236 => Map k (PatchTarget p) -> Map k (PatchTarget p) -> PatchMapWithPatchingMove k p

237patchThatChangesMap oldByIndex newByIndex = patch

238 where oldByValue = Map.fromListWith Set.union $ swap . first Set.singleton <$> Map.toList oldByIndex

239 (insertsAndMoves, unusedValuesByValue) = flip runState oldByValue $ do

240 let f k v = do

241 remainingValues <- get

242 let putRemainingKeys remainingKeys = put $ if Set.null remainingKeys

243 then Map.delete v remainingValues

244 else Map.insert v remainingKeys remainingValues

245 case Map.lookup v remainingValues of

246 Nothing -> return $ NodeInfo (From_Insert v) $ Just undefined -- There's no existing value we can take

247 Just fromKs ->

248 if k `Set.member` fromKs

249 then do

250 putRemainingKeys $ Set.delete k fromKs

251 return $ NodeInfo (From_Move k mempty) $ Just undefined -- There's an existing value, and it's here, so no patch necessary

252 else do

253 (fromK, remainingKeys) <- return . fromJust $ Set.minView fromKs -- There's an existing value, but it's not here; move it here

254 putRemainingKeys remainingKeys

255 return $ NodeInfo (From_Move fromK mempty) $ Just undefined

256 Map.traverseWithKey f newByIndex

257 unusedOldKeys = fold unusedValuesByValue

258 pointlessMove k = \case

259 From_Move k' _ | k == k' -> True

260 _ -> False

261 keyWasMoved k = if k `Map.member` oldByIndex && not (k `Set.member` unusedOldKeys)

262 then Just undefined

263 else Nothing

264 patch = unsafePatchMapWithPatchingMove $ Map.filterWithKey (\k -> not . pointlessMove k . _nodeInfo_from) $ Map.mergeWithKey (\k a _ -> Just $ nodeInfoSetTo (keyWasMoved k) a) (Map.mapWithKey $ \k -> nodeInfoSetTo $ keyWasMoved k) (Map.mapWithKey $ \k _ -> NodeInfo From_Delete $ keyWasMoved k) insertsAndMoves oldByIndex

265

266-- | Change the 'From' value of a 'NodeInfo'

267nodeInfoMapFrom

268 :: (From k v -> From k v) -> NodeInfo k v -> NodeInfo k v

269nodeInfoMapFrom f ni = ni { _nodeInfo_from = f $ _nodeInfo_from ni }

270

271-- | Change the 'From' value of a 'NodeInfo', using a 'Functor' (or

272-- 'Applicative', 'Monad', etc.) action to get the new value

273nodeInfoMapMFrom

274 :: Functor f => (From k v -> f (From k v)) -> NodeInfo k v -> f (NodeInfo k v)

275nodeInfoMapMFrom f ni = fmap (\result -> ni { _nodeInfo_from = result }) $ f $ _nodeInfo_from ni

276

277-- | Set the 'To' field of a 'NodeInfo'

278nodeInfoSetTo

279 :: To k -> NodeInfo k v -> NodeInfo k v

280nodeInfoSetTo to ni = ni { _nodeInfo_to = to }

281

282-- |Helper data structure used for composing patches using the monoid instance.

283data Fixup k v

284 = Fixup_Delete

285 | Fixup_Update (These (From k v) (To k))

286

287-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@

288instance ( Ord k

289 , Monoid p

290 , DecidablyEmpty p

291 , Patch p

292 ) => Semigroup (PatchMapWithPatchingMove k p) where

293 PatchMapWithPatchingMove ma <> PatchMapWithPatchingMove mb = PatchMapWithPatchingMove m

294 where

295 connections = Map.toList $ Map.intersectionWithKey (\_ a b -> (_nodeInfo_to a, _nodeInfo_from b)) ma mb

296 h :: (k, (Maybe k, From k p)) -> [(k, Fixup k p)]

297 h (_, (mToAfter, editBefore)) = case (mToAfter, editBefore) of

298 (Just toAfter, From_Move fromBefore p)

299 | fromBefore == toAfter && isEmpty p

300 -> [(toAfter, Fixup_Delete)]

301 | otherwise

302 -> [ (toAfter, Fixup_Update (This editBefore))

303 , (fromBefore, Fixup_Update (That mToAfter))

304 ]

305 (Nothing, From_Move fromBefore _) -> [(fromBefore, Fixup_Update (That mToAfter))] -- The item is destroyed in the second patch, so indicate that it is destroyed in the source map

306 (Just toAfter, _) -> [(toAfter, Fixup_Update (This editBefore))]

307 (Nothing, _) -> []

308 mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete

309 mergeFixups _ (Fixup_Update a) (Fixup_Update b)

310 | This x <- a, That y <- b

311 = Fixup_Update $ These x y

312 | That y <- a, This x <- b

313 = Fixup_Update $ These x y

314 mergeFixups _ _ _ = error "PatchMapWithPatchingMove: incompatible fixups"

315 fixups = Map.fromListWithKey mergeFixups $ concatMap h connections

316 combineNodeInfos _ nia nib = NodeInfo

317 { _nodeInfo_from = _nodeInfo_from nia

318 , _nodeInfo_to = _nodeInfo_to nib

319 }

320 applyFixup _ ni = \case

321 Fixup_Delete -> Nothing

322 Fixup_Update u -> Just $ NodeInfo

323 { _nodeInfo_from = case _nodeInfo_from ni of

324 f@(From_Move _ p') -> case getHere u of -- The `from` fixup comes from the "old" patch

325 Nothing -> f -- If there's no `from` fixup, just use the "new" `from`

326 Just (From_Insert v) -> From_Insert $ applyAlways p' v

327 Just From_Delete -> From_Delete

328 Just (From_Move oldKey p) -> From_Move oldKey $ p' <> p

329 _ -> error "PatchMapWithPatchingMove: fixup for non-move From"

330 , _nodeInfo_to = fromMaybe (_nodeInfo_to ni) $ getThere u

331 }

332 m = Map.differenceWithKey applyFixup (Map.unionWithKey combineNodeInfos ma mb) fixups

333 getHere :: These a b -> Maybe a

334 getHere = \case

335 This a -> Just a

336 These a _ -> Just a

337 That _ -> Nothing

338 getThere :: These a b -> Maybe b

339 getThere = \case

340 This _ -> Nothing

341 These _ b -> Just b

342 That b -> Just b

343

344--TODO: Figure out how to implement this in terms of PatchDMapWithPatchingMove rather than duplicating it here

345-- | Compose patches having the same effect as applying the patches in turn:

346-- @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@

347instance ( Ord k

348 , Monoid p

349 , DecidablyEmpty p

350 , Patch p

351 ) => Monoid (PatchMapWithPatchingMove k p) where

352 mempty = PatchMapWithPatchingMove mempty

353 mappend = (<>)

354

355makeWrapped ''PatchMapWithPatchingMove