git.iko.soy/patch
on dc90dd9 help sign in
patch/src/Reflex/Patch.hs
107 lines 4.3 kB history raw
1-- | This module defines the 'Patch' class, which is used by Reflex to manage
2-- changes to 'Reflex.Class.Incremental' values.
3{-# LANGUAGE CPP #-}
4{-# LANGUAGE DeriveFunctor #-}
5{-# LANGUAGE LambdaCase #-}
6{-# LANGUAGE StandaloneDeriving #-}
7{-# LANGUAGE TypeFamilies #-}
8{-# LANGUAGE GeneralizedNewtypeDeriving #-}
9module Reflex.Patch
10 ( Patch (..)
11 , PatchDMap (..)
12 , ComposeMaybe (..)
13 , PatchMap (..)
14 , Group (..)
15 , Additive
16 , AdditivePatch (..)
17 ) where
19import Control.Monad.Identity
20import Data.Dependent.Map (DMap, GCompare (..))
21import qualified Data.Dependent.Map as DMap
22import Data.Functor.Constant
23import Data.Map (Map)
24import qualified Data.Map as Map
25import Data.Semigroup (Semigroup (..), stimesIdempotentMonoid, (<>))
27-- | A 'Patch' type represents a kind of change made to a datastructure.
28class Patch p where
29 type PatchTarget p :: *
30 -- | Apply the patch @p a@ to the value @a@. If no change is needed, return
31 -- 'Nothing'.
32 apply :: p -> PatchTarget p -> Maybe (PatchTarget p)
34-- | We can't use @Compose Maybe@ instead of 'ComposeMaybe', because that would
35-- make the 'f' parameter have a nominal type role. We need f to be
36-- representational so that we can use safe 'coerce'.
37newtype ComposeMaybe f a = ComposeMaybe { getComposeMaybe :: Maybe (f a) }
39deriving instance Functor f => Functor (ComposeMaybe f)
41instance Patch (Identity a) where
42 type PatchTarget (Identity a) = a
43 apply (Identity a) _ = Just a
45-- | A set of changes to a 'DMap'. Any element may be inserted/updated or
46-- deleted.
47newtype PatchDMap k v = PatchDMap (DMap k (ComposeMaybe v))
49deriving instance GCompare k => Semigroup (PatchDMap k v)
51deriving instance GCompare k => Monoid (PatchDMap k v)
53instance GCompare k => Patch (PatchDMap k v) where
54 type PatchTarget (PatchDMap k v) = DMap k v
55 apply (PatchDMap diff) old = Just $! insertions `DMap.union` (old `DMap.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?
56 where insertions = DMap.mapMaybeWithKey (const $ getComposeMaybe) diff
57 deletions = DMap.mapMaybeWithKey (const $ nothingToJust . getComposeMaybe) diff
58 nothingToJust = \case
59 Nothing -> Just $ Constant ()
60 Just _ -> Nothing
62-- | A set of changes to a 'Map'. Any element may be inserted/updated or
63-- deleted.
64newtype PatchMap k v = PatchMap (Map k (Maybe v))
66instance Ord k => Patch (PatchMap k v) where
67 type PatchTarget (PatchMap k v) = Map k v
68 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?
69 where insertions = Map.mapMaybeWithKey (const id) p
70 deletions = Map.mapMaybeWithKey (const nothingToJust) p
71 nothingToJust = \case
72 Nothing -> Just ()
73 Just _ -> Nothing
75instance Ord k => Semigroup (PatchMap k v) where
76 PatchMap a <> PatchMap b = PatchMap $ a `mappend` b --TODO: Add a semigroup instance for Map
77 -- PatchMap is idempotent, so stimes n is id for every n
78#if MIN_VERSION_semigroups(0,17,0)
79 stimes = stimesIdempotentMonoid
80#else
81 times1p n x = case compare n 0 of
82 LT -> error "stimesIdempotentMonoid: negative multiplier"
83 EQ -> mempty
84 GT -> x
85#endif
87instance Ord k => Monoid (PatchMap k v) where
88 mempty = PatchMap mempty
89 mappend = (<>)
91---- Patches based on commutative groups
93-- | A 'Group' is a 'Monoid' where every element has an inverse.
94class (Semigroup q, Monoid q) => Group q where
95 negateG :: q -> q
96 (~~) :: q -> q -> q
97 r ~~ s = r <> negateG s
99-- | An 'Additive' 'Semigroup' is one where the multiplication is commutative
100class Semigroup q => Additive q where
102-- | The elements of an 'Additive' 'Semigroup' can be considered as patches of their own type.
103newtype AdditivePatch p = AdditivePatch { unAdditivePatch :: p }
105instance Additive p => Patch (AdditivePatch p) where
106 type PatchTarget (AdditivePatch p) = p
107 apply (AdditivePatch p) q = Just $ p <> q