WIP add a couple of types for working with patches

reflex.cabal

@@ -115,9 +115,11 @@ library
     Reflex.Patch.Class,
     Reflex.Patch.DMap,
     Reflex.Patch.DMapWithMove,
+    Reflex.Patch.DMapWithReset,
     Reflex.Patch.IntMap,
     Reflex.Patch.Map,
     Reflex.Patch.MapWithMove,
+    Reflex.Patch.Patchable,
     Reflex.PerformEvent.Base,
     Reflex.PerformEvent.Class,
     Reflex.PostBuild.Base,

src/Reflex/Patch/DMapWithReset.hs

@@ -0,0 +1,120 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+{-# OPTIONS_GHC -Wall #-}
+
+-- | 'Patch'es on 'DMap' that consist only of insertions (or overwrites) and deletions.
+module Reflex.Patch.DMapWithReset where
+
+import Reflex.Patch.Class
+
+import Data.Dependent.Map (DMap, GCompare (..))
+import qualified Data.Dependent.Map as DMap
+import Data.Semigroup (Semigroup (..))
+import Data.Constraint.Extras
+
+-- | A set of changes to a 'DMap'.  Any element may be inserted/updated or deleted.
+-- Insertions are represented as @'ComposeMaybe' (Just value)@,
+-- while deletions are represented as @'ComposeMaybe' Nothing@.
+newtype PatchDMapWithReset k p = PatchDMapWithReset { unPatchDMapWithReset :: DMap k (By p) }
+
+-- | Holds the information about each key: where its new value should come from,
+-- and where its old value should go to
+data By p a
+  = By_Insert (PatchTarget (p a)) -- ^ Insert the given value here
+  | By_Delete -- ^ Delete the existing value, if any, from here
+  | By_Patch (p a) -- ^ Patch the value here with the given patch
+
+instance (Semigroup (p a), Patch (p a)) => Semigroup (By p a) where
+  x@(By_Insert _) <> _ = x
+  By_Delete <> _ = By_Delete
+  By_Patch x <> By_Insert y = By_Insert (applyAlways x y)
+  By_Patch x <> By_Patch y = By_Patch (x <> y)
+  By_Patch _ <> By_Delete = By_Delete
+
+instance (Monoid (p a), Patch (p a)) => Monoid (By p a) where
+  mappend = (<>)
+  mempty = By_Patch mempty
+
+instance
+    ( GCompare k
+    , Has' Semigroup k p
+    , Has' Patch k p
+    )
+    => Semigroup (PatchDMapWithReset k p) where
+  PatchDMapWithReset xs <> PatchDMapWithReset ys = PatchDMapWithReset $ DMap.unionWithKey
+    (\k -> has' @Patch @p k
+         $ has' @Semigroup @p k
+         $ (<>)) xs ys
+
+instance
+    ( GCompare k
+    , Has' Semigroup k p
+    , Has' Patch k p
+    )
+    => Monoid (PatchDMapWithReset k p) where
+  mappend = (<>)
+  mempty = PatchDMapWithReset DMap.empty
+
+class (Patch (p a), PatchTarget (p a) ~ Patches1LocallyTarget p a) => Patches1Locally p a where
+  type Patches1LocallyTarget p :: k -> *
+
+data These1 f g x
+  = This1 (f x)
+  | That1 (g x)
+  | These1 (f x) (g x)
+
+mergeWithKey
+  :: forall k v1 v2 v.
+  (GCompare k)
+  => (forall x. k x -> v1 x -> Maybe (v x))
+  -> (forall x. k x -> v2 x -> Maybe (v x))
+  -> (forall x. k x -> v1 x -> v2 x -> Maybe (v x))
+  -> DMap k v1 -> DMap k v2 -> DMap k v
+mergeWithKey f g fg = \xs ys -> DMap.mapMaybeWithKey onlyThat $ DMap.unionWithKey doIt (DMap.map This1 xs) (DMap.map That1 ys)
+  where
+    doIt _ (This1 xs) (That1 ys) = These1 xs ys
+    doIt _ _ _ = error "mergeWithKey misalligned keys"
+
+    onlyThat :: forall x. k x -> These1 v1 v2 x -> Maybe (v x)
+    onlyThat k = \case
+      This1 xs -> f k xs
+      That1 ys -> g k ys
+      These1 xs ys -> fg k xs ys
+{-# INLINE mergeWithKey #-}
+
+-- | Apply the insertions or deletions to a given 'DMap'.
+instance (GCompare k, Has (Patches1Locally p) k) => Patch (PatchDMapWithReset k p) where
+
+  type PatchTarget (PatchDMapWithReset k p) = DMap k (Patches1LocallyTarget p)
+
+  apply = go
+    where
+      go :: PatchDMapWithReset k p -> DMap k (Patches1LocallyTarget p) -> Maybe (DMap k (Patches1LocallyTarget p))
+      go (PatchDMapWithReset diff) old = Just $! mergeWithKey (\_ -> Just) inserts updates old diff
+        where
+          updates :: forall x. k x -> Patches1LocallyTarget p x -> By p x -> Maybe (Patches1LocallyTarget p x)
+          updates k ys = has @(Patches1Locally p) k $ \case
+            By_Insert x -> Just x
+            By_Delete -> Nothing
+            By_Patch x -> Just $ applyAlways x ys
+
+          inserts :: forall x. k x -> By p x -> Maybe (Patches1LocallyTarget p x)
+          inserts k = has @(Patches1Locally p) k $ \case
+            By_Insert x -> Just x
+            By_Delete -> Nothing
+            By_Patch _ -> Nothing
+
+deriving instance (Patch (p a), Eq (p a), Eq (PatchTarget (p a))) => Eq (By p a)
+deriving instance (Patch (p a), Show (p a), Show (PatchTarget (p a))) => Show (By p a)
+deriving instance (Eq (DMap k (By p))) => Eq (PatchDMapWithReset k p)
+deriving instance (Show (DMap k (By p))) => Show (PatchDMapWithReset k p)

src/Reflex/Patch/Patchable.hs

@@ -0,0 +1,44 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeFamilies #-}
+
+-- The derived instances are undecidable in the case of a pathological instance like
+-- instance Patch x where
+--   type PatchTarget x = Patchable x
+{-# LANGUAGE UndecidableInstances #-}
+
+module Reflex.Patch.Patchable where
+
+-- import Data.Aeson
+import GHC.Generics
+import Reflex.Patch
+
+-- | Like SemiMap/PartialMap but for anything patchable
+data Patchable p
+  = Patchable_Patch p
+  | Patchable_Complete (PatchTarget p)
+  deriving (Generic)
+
+completePatchable :: Patchable p -> Maybe (PatchTarget p)
+completePatchable = \case
+  Patchable_Complete t -> Just t
+  Patchable_Patch _ -> Nothing
+
+deriving instance (Eq p, Eq (PatchTarget p)) => Eq (Patchable p)
+deriving instance (Ord p, Ord (PatchTarget p)) => Ord (Patchable p)
+deriving instance (Show p, Show (PatchTarget p)) => Show (Patchable p)
+deriving instance (Read p, Read (PatchTarget p)) => Read (Patchable p)
+-- instance (ToJSON p, ToJSON (PatchTarget p)) => ToJSON (Patchable p)
+-- instance (FromJSON p, FromJSON (PatchTarget p)) => FromJSON (Patchable p)
+
+instance (Monoid p, Patch p) => Monoid (Patchable p) where
+  mempty = Patchable_Patch mempty
+  mappend = (<>)
+
+instance (Semigroup p, Patch p) => Semigroup (Patchable p) where
+  (<>) = curry $ \case
+    (Patchable_Patch a, Patchable_Patch b) -> Patchable_Patch $ a <> b
+    (Patchable_Patch a, Patchable_Complete b) -> Patchable_Complete $ applyAlways a b
+    (Patchable_Complete a, _) -> Patchable_Complete a