Merge pull request #1 from reflex-frp/patch-map-inner-patch

Add PatchMapWithPatchingMove

Author: Ericson2314

ChangeLog.md

@@ -1,5 +1,11 @@
 # Revision history for patch
 
+## Unreleased
+
+* Create `PatchMapWithPatchingMove` variant which supports moves with a patch.
+
+* Create `DecidablyEmpty` subclass of `Monoid`.
+
 ## 0.0.2.0
 
 * Consistently provide:

patch.cabal

@@ -41,13 +41,15 @@ library
                , witherable >= 0.3 && < 0.3.2
 
   exposed-modules: Data.Functor.Misc
+                 , Data.Monoid.DecidablyEmpty
                  , Data.Patch
                  , Data.Patch.Class
                  , Data.Patch.DMap
                  , Data.Patch.DMapWithMove
                  , Data.Patch.IntMap
                  , Data.Patch.Map
                  , Data.Patch.MapWithMove
+                 , Data.Patch.MapWithPatchingMove
 
   ghc-options: -Wall -fwarn-redundant-constraints -fwarn-tabs
 

src/Data/Monoid/DecidablyEmpty.hs

@@ -0,0 +1,115 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeOperators #-}
+
+-- TODO upstream somwhere else?
+module Data.Monoid.DecidablyEmpty where
+
+import Data.Functor.Identity
+import Data.Functor.Const
+import Data.Monoid
+import Data.Maybe (isNothing)
+#if MIN_VERSION_base(4,11,0)
+import Data.Ord
+#endif
+import Data.Proxy
+import Data.Semigroup hiding (First, Last)
+#if MIN_VERSION_base(4,12,0)
+import GHC.Generics
+#endif
+
+import qualified Data.IntSet as IntSet
+import qualified Data.IntMap as IntMap
+import qualified Data.Map as Map
+import qualified Data.Sequence as Seq
+import qualified Data.Set as Set
+
+import Data.GADT.Compare
+import qualified Data.Dependent.Map as DMap
+
+-- | A 'DecidablyEmpty' is one where it can be computed whether or not an
+-- arbitrary value is 'mempty'.
+--
+-- By using this class rather than 'Eq', we avoid unnecessary constraining the
+-- contents of 'Functor's. This makes it possible to efficiently combine and/or
+-- nest patch maps with 'Eq'-lacking values (e.g. functions) at the leaves.
+class Monoid a => DecidablyEmpty a where
+  isEmpty :: a -> Bool
+  default isEmpty :: Eq a => a -> Bool
+  isEmpty = (==) mempty
+
+-- base
+
+instance DecidablyEmpty Ordering
+instance DecidablyEmpty ()
+instance DecidablyEmpty Any
+instance DecidablyEmpty All
+-- instance DecidablyEmpty Lifetime
+-- instance DecidablyEmpty Event
+instance DecidablyEmpty [a] where
+  isEmpty = null
+instance
+#if MIN_VERSION_base(4,11,0)
+  Semigroup a
+#else
+  Monoid a
+#endif
+  => DecidablyEmpty (Maybe a) where
+  isEmpty = isNothing
+deriving instance (Num a, DecidablyEmpty a) => DecidablyEmpty (Product a)
+deriving instance (DecidablyEmpty a, Num a) => DecidablyEmpty (Sum a)
+deriving instance DecidablyEmpty a => DecidablyEmpty (Dual a)
+instance DecidablyEmpty (First a) where
+  isEmpty (First a) = isNothing a
+instance DecidablyEmpty (Last a) where
+  isEmpty (Last a) = isNothing a
+deriving instance DecidablyEmpty a => DecidablyEmpty (Identity a)
+instance Semigroup a => DecidablyEmpty (Option a) where
+  isEmpty (Option a) = isNothing a
+deriving instance DecidablyEmpty m => DecidablyEmpty (WrappedMonoid m)
+instance (Ord a, Bounded a) => DecidablyEmpty (Max a)
+instance (Ord a, Bounded a) => DecidablyEmpty (Min a)
+instance DecidablyEmpty (Proxy s)
+deriving instance DecidablyEmpty a => DecidablyEmpty (Const a b)
+#if MIN_VERSION_base(4,11,0)
+deriving instance DecidablyEmpty a => DecidablyEmpty (Down a)
+#endif
+#if MIN_VERSION_base(4,12,0)
+deriving instance DecidablyEmpty p => DecidablyEmpty (Par1 p)
+instance DecidablyEmpty (U1 p)
+deriving instance DecidablyEmpty (f p) => DecidablyEmpty (Rec1 f p)
+deriving instance DecidablyEmpty (f p) => DecidablyEmpty (M1 i c f p)
+deriving instance DecidablyEmpty c => DecidablyEmpty (K1 i c p)
+instance (DecidablyEmpty (f p), DecidablyEmpty (g p)) => DecidablyEmpty ((f :*: g) p) where
+  isEmpty (x :*: y) = isEmpty x && isEmpty y
+deriving instance DecidablyEmpty (f (g p)) => DecidablyEmpty ((f :.: g) p)
+#endif
+
+instance (DecidablyEmpty a, DecidablyEmpty b) => DecidablyEmpty (a, b) where
+  isEmpty (a, b) = isEmpty a && isEmpty b
+instance (DecidablyEmpty a, DecidablyEmpty b, DecidablyEmpty c) => DecidablyEmpty (a, b, c) where
+  isEmpty (a, b, c) = isEmpty a && isEmpty b && isEmpty c
+instance (DecidablyEmpty a, DecidablyEmpty b, DecidablyEmpty c, DecidablyEmpty d) => DecidablyEmpty (a, b, c, d) where
+  isEmpty (a, b, c, d) = isEmpty a && isEmpty b && isEmpty c && isEmpty d
+instance (DecidablyEmpty a, DecidablyEmpty b, DecidablyEmpty c, DecidablyEmpty d, DecidablyEmpty e) => DecidablyEmpty (a, b, c, d, e) where
+  isEmpty (a, b, c, d, e) = isEmpty a && isEmpty b && isEmpty c && isEmpty d && isEmpty e
+
+-- containers
+
+instance DecidablyEmpty IntSet.IntSet where
+  isEmpty = IntSet.null
+instance DecidablyEmpty (IntMap.IntMap v) where
+  isEmpty = IntMap.null
+instance Ord k => DecidablyEmpty (Map.Map k v) where
+  isEmpty = Map.null
+instance DecidablyEmpty (Seq.Seq v) where
+  isEmpty = Seq.null
+instance Ord k => DecidablyEmpty (Set.Set k) where
+  isEmpty = Set.null
+
+-- dependent-map
+
+instance GCompare k => DecidablyEmpty (DMap.DMap k v) where
+  isEmpty = DMap.null

src/Data/Patch.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeFamilies #-}
@@ -12,24 +13,31 @@ module Data.Patch
   , module X
   ) where
 
+import Control.Applicative
+import Data.Functor.Const (Const (..))
+import Data.Functor.Identity
+import Data.Map.Monoidal (MonoidalMap)
+import Data.Proxy
+#if !MIN_VERSION_base(4,11,0)
+import Data.Semigroup (Semigroup (..))
+#endif
+import GHC.Generics
+
 import Data.Patch.Class as X
 import Data.Patch.DMap as X hiding (getDeletions)
-import Data.Patch.DMapWithMove as X (PatchDMapWithMove, const2PatchDMapWithMoveWith, mapPatchDMapWithMove,
-                                       patchDMapWithMoveToPatchMapWithMoveWith,
-                                       traversePatchDMapWithMoveWithKey, unPatchDMapWithMove,
-                                       unsafePatchDMapWithMove, weakenPatchDMapWithMoveWith)
+import Data.Patch.DMapWithMove as X
+  ( PatchDMapWithMove, const2PatchDMapWithMoveWith, mapPatchDMapWithMove
+  , patchDMapWithMoveToPatchMapWithMoveWith
+  , traversePatchDMapWithMoveWithKey, unPatchDMapWithMove
+  , unsafePatchDMapWithMove, weakenPatchDMapWithMoveWith
+  )
 import Data.Patch.IntMap as X hiding (getDeletions)
 import Data.Patch.Map as X
-import Data.Patch.MapWithMove as X (PatchMapWithMove, patchMapWithMoveNewElements,
-                                      patchMapWithMoveNewElementsMap, unPatchMapWithMove,
-                                      unsafePatchMapWithMove)
-import Data.Map.Monoidal (MonoidalMap)
-import Data.Semigroup (Semigroup (..), (<>))
-import GHC.Generics
-import Data.Functor.Identity
-import Data.Functor.Const
-import Data.Proxy
-import Control.Applicative
+import Data.Patch.MapWithMove as X
+  ( PatchMapWithMove, patchMapWithMoveNewElements
+  , patchMapWithMoveNewElementsMap, unPatchMapWithMove
+  , unsafePatchMapWithMove
+  )
 
 -- | A 'Group' is a 'Monoid' where every element has an inverse.
 class (Semigroup q, Monoid q) => Group q where

src/Data/Patch/Class.hs

@@ -1,10 +1,14 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE TypeFamilies #-}
 -- | The interface for types which represent changes made to other types
 module Data.Patch.Class where
 
 import Data.Functor.Identity
 import Data.Maybe
+#if !MIN_VERSION_base(4,11,0)
 import Data.Semigroup (Semigroup(..))
+#endif
+import Data.Proxy
 
 -- | A 'Patch' type represents a kind of change made to a datastructure.
 --
@@ -25,6 +29,11 @@ instance Patch (Identity a) where
   type PatchTarget (Identity a) = a
   apply (Identity a) _ = Just a
 
+-- | 'Proxy' can be used as a 'Patch' that does nothing.
+instance Patch (Proxy a) where
+  type PatchTarget (Proxy a) = a
+  apply ~Proxy _ = Nothing
+
 -- | Like '(.)', but composes functions that return patches rather than
 -- functions that return new values.  The Semigroup instance for patches must
 -- apply patches right-to-left, like '(.)'.

src/Data/Patch/DMap.hs

@@ -1,10 +1,12 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE PolyKinds #-}
 {-# LANGUAGE Rank2Types #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeFamilies #-}
+
 -- | 'Patch'es on 'DMap' that consist only of insertions (or overwrites) and deletions.
 module Data.Patch.DMap where
 
@@ -18,7 +20,10 @@ import Data.Functor.Constant
 import Data.Functor.Misc
 import qualified Data.IntMap as IntMap
 import qualified Data.Map as Map
+import Data.Monoid.DecidablyEmpty
+#if !MIN_VERSION_base(4,11,0)
 import Data.Semigroup (Semigroup (..))
+#endif
 import Data.Some (Some)
 
 -- | A set of changes to a 'DMap'.  Any element may be inserted/updated or deleted.
@@ -30,6 +35,10 @@ deriving instance GCompare k => Semigroup (PatchDMap k v)
 
 deriving instance GCompare k => Monoid (PatchDMap k v)
 
+-- It won't let me derive for some reason
+instance GCompare k => DecidablyEmpty (PatchDMap k v) where
+  isEmpty (PatchDMap m) = DMap.null m
+
 -- | Apply the insertions or deletions to a given 'DMap'.
 instance GCompare k => Patch (PatchDMap k v) where
   type PatchTarget (PatchDMap k v) = DMap k v

src/Data/Patch/DMapWithMove.hs

@@ -29,7 +29,10 @@ import Data.GADT.Compare (GEq (..))
 import Data.GADT.Show (GShow, gshow)
 import qualified Data.Map as Map
 import Data.Maybe
-import Data.Semigroup (Semigroup (..), (<>))
+import Data.Monoid.DecidablyEmpty
+#if !MIN_VERSION_base(4,11,0)
+import Data.Semigroup (Semigroup (..))
+#endif
 import Data.Some (Some(Some))
 import Data.These
 
@@ -42,6 +45,10 @@ import Data.These
 --     * A move should always be represented with both the destination key (as a 'From_Move') and the source key (as a @'ComposeMaybe' ('Just' destination)@)
 newtype PatchDMapWithMove k v = PatchDMapWithMove (DMap k (NodeInfo k v))
 
+-- It won't let me derive for some reason
+instance GCompare k => DecidablyEmpty (PatchDMapWithMove k v) where
+  isEmpty (PatchDMapWithMove m) = DMap.null m
+
 -- |Structure which represents what changes apply to a particular key. @_nodeInfo_from@ specifies what happens to this key, and in particular what other key
 -- the current key is moving from, while @_nodeInfo_to@ specifies what key the current key is moving to if involved in a move.
 data NodeInfo k v a = NodeInfo

src/Data/Patch/IntMap.hs

@@ -1,7 +1,9 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE DeriveTraversable #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TypeFamilies #-}
 
@@ -13,24 +15,25 @@ import Control.Lens
 import Data.IntMap.Strict (IntMap)
 import qualified Data.IntMap.Strict as IntMap
 import Data.Maybe
-import Data.Semigroup
+import Data.Monoid.DecidablyEmpty
+#if !MIN_VERSION_base(4,11,0)
+import Data.Semigroup (Semigroup (..))
+#endif
 import Data.Patch.Class
 
 -- | 'Patch' for 'IntMap' which represents insertion or deletion of keys in the mapping.
 -- Internally represented by 'IntMap (Maybe a)', where @Just@ means insert/update
 -- and @Nothing@ means delete.
 newtype PatchIntMap a = PatchIntMap { unPatchIntMap :: IntMap (Maybe a) }
   deriving ( Show, Read, Eq, Ord
-           , Functor, Foldable, Traversable, Monoid
+           , Functor, Foldable, Traversable
+           , Monoid, DecidablyEmpty
            )
 
 -- | @a <> b@ will apply the changes of @b@ and then apply the changes of @a@.
 -- If the same key is modified by both patches, the one on the left will take
 -- precedence.
-instance Semigroup (PatchIntMap v) where
-  PatchIntMap a <> PatchIntMap b = PatchIntMap $ a `mappend` b --TODO: Add a semigroup instance for Map
-  -- PatchMap is idempotent, so stimes n is id for every n
-  stimes = stimesIdempotentMonoid
+deriving instance Semigroup (PatchIntMap v)
 
 makeWrapped ''PatchIntMap
 

src/Data/Patch/Map.hs

@@ -1,5 +1,7 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE DeriveTraversable #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE StandaloneDeriving #-}
@@ -16,19 +18,23 @@ import Control.Lens
 import Data.Map (Map)
 import qualified Data.Map as Map
 import Data.Maybe
-import Data.Semigroup
+import Data.Monoid.DecidablyEmpty
+import Data.Semigroup (Semigroup (..), stimesIdempotentMonoid)
 
 -- | A set of changes to a 'Map'.  Any element may be inserted/updated or
 -- deleted.  Insertions are represented as values wrapped in 'Just', while
 -- deletions are represented as 'Nothing's
 newtype PatchMap k v = PatchMap { unPatchMap :: Map k (Maybe v) }
   deriving ( Show, Read, Eq, Ord
            , Foldable, Traversable
+           , DecidablyEmpty
            )
 
 -- | 'fmap'ping a 'PatchMap' will alter all of the values it will insert.
 -- Deletions are unaffected.
 deriving instance Functor (PatchMap k)
+-- | The empty 'PatchMap' contains no insertions or deletions
+deriving instance Ord k => Monoid (PatchMap k v)
 
 -- | @a <> b@ will apply the changes of @b@ and then apply the changes of @a@.
 -- If the same key is modified by both patches, the one on the left will take
@@ -38,8 +44,6 @@ instance Ord k => Semigroup (PatchMap k v) where
   -- PatchMap is idempotent, so stimes n is id for every n
   stimes = stimesIdempotentMonoid
 
-makeWrapped ''PatchMap
-
 -- | Apply the insertions or deletions to a given 'Map'.
 instance Ord k => Patch (PatchMap k v) where
   type PatchTarget (PatchMap k v) = Map k v
@@ -57,15 +61,12 @@ instance TraversableWithIndex k (PatchMap k) where
   itraverse = itraversed . Indexed
   itraversed = _Wrapped .> itraversed <. traversed
 
--- | The empty 'PatchMap' contains no insertions or deletions
-instance Ord k => Monoid (PatchMap k v) where
-  mempty = PatchMap mempty
-  mappend = (<>)
-
 -- | Returns all the new elements that will be added to the 'Map'
 patchMapNewElements :: PatchMap k v -> [v]
 patchMapNewElements (PatchMap p) = catMaybes $ Map.elems p
 
 -- | Returns all the new elements that will be added to the 'Map'
 patchMapNewElementsMap :: PatchMap k v -> Map k v
 patchMapNewElementsMap (PatchMap p) = Map.mapMaybe id p
+
+makeWrapped ''PatchMap

src/Data/Patch/MapWithMove.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE DeriveTraversable #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
@@ -24,7 +25,9 @@ import Data.List
 import Data.Map (Map)
 import qualified Data.Map as Map
 import Data.Maybe
-import Data.Semigroup (Semigroup (..), (<>))
+#if !MIN_VERSION_base(4,11,0)
+import Data.Semigroup (Semigroup (..))
+#endif
 import qualified Data.Set as Set
 import Data.These (These(..))
 import Data.Tuple