git.iko.soy/patch
on 9fd59f3 help sign in
patch/src/Reflex/Patch/Map.hs
52 lines 1.9 kB history raw
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE LambdaCase #-}
3{-# LANGUAGE TypeFamilies #-}
4module Reflex.Patch.Map where
6import Reflex.Patch.Class
8import Data.Semigroup
9import Data.Map (Map)
10import qualified Data.Map as Map
11import Data.Maybe
13-- | A set of changes to a 'Map'. Any element may be inserted/updated or
14-- deleted.
15newtype PatchMap k v = PatchMap { unPatchMap :: Map k (Maybe v) }
17instance Ord k => Patch (PatchMap k v) where
18 type PatchTarget (PatchMap k v) = Map k v
19 {-# INLINABLE apply #-}
20 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?
21 where insertions = Map.mapMaybeWithKey (const id) p
22 deletions = Map.mapMaybeWithKey (const nothingToJust) p
23 nothingToJust = \case
24 Nothing -> Just ()
25 Just _ -> Nothing
27instance Ord k => Semigroup (PatchMap k v) where
28 PatchMap a <> PatchMap b = PatchMap $ a `mappend` b --TODO: Add a semigroup instance for Map
29 -- PatchMap is idempotent, so stimes n is id for every n
30#if MIN_VERSION_semigroups(0,17,0)
31 stimes = stimesIdempotentMonoid
32#else
33 times1p n x = case compare n 0 of
34 LT -> error "stimesIdempotentMonoid: negative multiplier"
35 EQ -> mempty
36 GT -> x
37#endif
39instance Ord k => Monoid (PatchMap k v) where
40 mempty = PatchMap mempty
41 mappend = (<>)
43instance Functor (PatchMap k) where
44 fmap f = PatchMap . fmap (fmap f) . unPatchMap
46-- | Returns all the new elements that will be added to the 'Map'
47patchMapNewElements :: PatchMap k v -> [v]
48patchMapNewElements (PatchMap p) = catMaybes $ Map.elems p
50-- | Returns all the new elements that will be added to the 'Map'
51patchMapNewElementsMap :: PatchMap k v -> Map k v
52patchMapNewElementsMap (PatchMap p) = Map.mapMaybe id p