From d66d5e9ee657d72a709edf6c98407a2f7b7347f3 Mon Sep 17 00:00:00 2001 From: Dan Bornside Date: Wed, 18 Sep 2019 17:56:18 -0400 Subject: [PATCH 1/2] add a couple of types for working with patches --- reflex.cabal | 2 + src/Reflex/Patch/DMapWithReset.hs | 120 ++++++++++++++++++++++++++++++ src/Reflex/Patch/Patchable.hs | 44 +++++++++++ 3 files changed, 166 insertions(+) create mode 100644 src/Reflex/Patch/DMapWithReset.hs create mode 100644 src/Reflex/Patch/Patchable.hs diff --git a/reflex.cabal b/reflex.cabal index a0984333..c85ed247 100644 --- a/reflex.cabal +++ b/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, diff --git a/src/Reflex/Patch/DMapWithReset.hs b/src/Reflex/Patch/DMapWithReset.hs new file mode 100644 index 00000000..b8bb7f31 --- /dev/null +++ b/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) diff --git a/src/Reflex/Patch/Patchable.hs b/src/Reflex/Patch/Patchable.hs new file mode 100644 index 00000000..2c529abe --- /dev/null +++ b/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 pathlogical 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 From 732cb147ca0c8df0957bae94d8611829a760daad Mon Sep 17 00:00:00 2001 From: Dan Bornside Date: Wed, 25 Sep 2019 17:58:46 -0400 Subject: [PATCH 2/2] Update src/Reflex/Patch/Patchable.hs Co-Authored-By: Alexandre Esteves <2335822+alexfmpe@users.noreply.github.com> --- src/Reflex/Patch/Patchable.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Reflex/Patch/Patchable.hs b/src/Reflex/Patch/Patchable.hs index 2c529abe..e699b0e8 100644 --- a/src/Reflex/Patch/Patchable.hs +++ b/src/Reflex/Patch/Patchable.hs @@ -4,7 +4,7 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} --- The derived instances are undecidable in the case of a pathlogical instance like +-- The derived instances are undecidable in the case of a pathological instance like -- instance Patch x where -- type PatchTarget x = Patchable x {-# LANGUAGE UndecidableInstances #-}