git.iko.soy/patch
on develop help sign in
patch/src/Data/Patch/Map.hs
72 lines 2.9 kB history raw
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE DeriveTraversable #-}
3{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5{-# LANGUAGE LambdaCase #-}
6{-# LANGUAGE MultiParamTypeClasses #-}
7{-# LANGUAGE StandaloneDeriving #-}
8{-# LANGUAGE TemplateHaskell #-}
9{-# LANGUAGE TypeFamilies #-}
11-- | 'Patch'es on 'Map' that consist only of insertions (including overwrites)
12-- and deletions
13module Data.Patch.Map where
15import Data.Patch.Class
17import Control.Lens
18import Data.Map (Map)
19import qualified Data.Map as Map
20import Data.Maybe
21import Data.Monoid.DecidablyEmpty
22import Data.Semigroup (Semigroup (..), stimesIdempotentMonoid)
24-- | A set of changes to a 'Map'. Any element may be inserted/updated or
25-- deleted. Insertions are represented as values wrapped in 'Just', while
26-- deletions are represented as 'Nothing's
27newtype PatchMap k v = PatchMap { unPatchMap :: Map k (Maybe v) }
28 deriving ( Show, Read, Eq, Ord
29 , Foldable, Traversable
30 , DecidablyEmpty
31 )
33-- | 'fmap'ping a 'PatchMap' will alter all of the values it will insert.
34-- Deletions are unaffected.
35deriving instance Functor (PatchMap k)
36-- | The empty 'PatchMap' contains no insertions or deletions
37deriving instance Ord k => Monoid (PatchMap k v)
39-- | @a <> b@ will apply the changes of @b@ and then apply the changes of @a@.
40-- If the same key is modified by both patches, the one on the left will take
41-- precedence.
42instance Ord k => Semigroup (PatchMap k v) where
43 PatchMap a <> PatchMap b = PatchMap $ a `mappend` b --TODO: Add a semigroup instance for Map
44 -- PatchMap is idempotent, so stimes n is id for every n
45 stimes = stimesIdempotentMonoid
47-- | Apply the insertions or deletions to a given 'Map'.
48instance Ord k => Patch (PatchMap k v) where
49 type PatchTarget (PatchMap k v) = Map k v
50 {-# INLINABLE apply #-}
51 apply (PatchMap p) old = Just $! insertions `Map.union` (old `Map.difference` deletions) --TODO: return Nothing sometimes --Note: the strict application here is critical to ensuring that incremental merges don't hold onto all their prerequisite events forever; can we make this more robust?
52 where insertions = Map.mapMaybeWithKey (const id) p
53 deletions = Map.mapMaybeWithKey (const nothingToJust) p
54 nothingToJust = \case
55 Nothing -> Just ()
56 Just _ -> Nothing
58instance FunctorWithIndex k (PatchMap k)
59instance FoldableWithIndex k (PatchMap k)
60instance TraversableWithIndex k (PatchMap k) where
61 itraverse = itraversed . Indexed
62 itraversed = _Wrapped .> itraversed <. traversed
64-- | Returns all the new elements that will be added to the 'Map'
65patchMapNewElements :: PatchMap k v -> [v]
66patchMapNewElements (PatchMap p) = catMaybes $ Map.elems p
68-- | Returns all the new elements that will be added to the 'Map'
69patchMapNewElementsMap :: PatchMap k v -> Map k v
70patchMapNewElementsMap (PatchMap p) = Map.mapMaybe id p
72makeWrapped ''PatchMap