Add Indexed* classes and newtype wrappers for other patch classes

Author: Ericson2314

src/Data/Patch/IntMap.hs

@@ -1,11 +1,10 @@
-{-# LANGUAGE DeriveFoldable #-}
-{-# LANGUAGE DeriveFunctor #-}
 {-# LANGUAGE DeriveTraversable #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TypeFamilies #-}
+
 -- | Module containing 'PatchIntMap', a 'Patch' for 'IntMap' which allows for
 -- insert/update or delete of associations.
 module Data.Patch.IntMap where
@@ -20,7 +19,10 @@ 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 (IntMap (Maybe a)) deriving (Functor, Foldable, Traversable, Monoid)
+newtype PatchIntMap a = PatchIntMap { unPatchIntMap :: IntMap (Maybe a) }
+  deriving ( Show, Read, Eq, Ord
+           , Functor, Foldable, Traversable, Monoid
+           )
 
 -- | @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

src/Data/Patch/Map.hs

@@ -1,11 +1,18 @@
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TypeFamilies #-}
+
 -- | 'Patch'es on 'Map' that consist only of insertions (including overwrites)
 -- and deletions
 module Data.Patch.Map where
 
 import Data.Patch.Class
 
+import Control.Lens
 import Data.Map (Map)
 import qualified Data.Map as Map
 import Data.Maybe
@@ -15,7 +22,23 @@ import Data.Semigroup
 -- 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)
+  deriving ( Show, Read, Eq, Ord
+           , Foldable, Traversable
+           )
+
+-- | 'fmap'ping a 'PatchMap' will alter all of the values it will insert.
+-- Deletions are unaffected.
+deriving instance Functor (PatchMap k)
+
+-- | @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 Ord k => Semigroup (PatchMap k v) where
+  PatchMap a <> PatchMap b = PatchMap $ a `mappend` b --TODO: Add a semigroup instance for Map
+  -- 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
@@ -28,24 +51,16 @@ instance Ord k => Patch (PatchMap k v) where
             Nothing -> Just ()
             Just _ -> Nothing
 
--- | @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 Ord k => Semigroup (PatchMap k v) where
-  PatchMap a <> PatchMap b = PatchMap $ a `mappend` b --TODO: Add a semigroup instance for Map
-  -- PatchMap is idempotent, so stimes n is id for every n
-  stimes = stimesIdempotentMonoid
+instance FunctorWithIndex k (PatchMap k)
+instance FoldableWithIndex k (PatchMap k)
+instance TraversableWithIndex k (PatchMap k) where
+  itraverse f (PatchMap x) = PatchMap <$> itraverse (traverse . f) x
 
 -- | The empty 'PatchMap' contains no insertions or deletions
 instance Ord k => Monoid (PatchMap k v) where
   mempty = PatchMap mempty
   mappend = (<>)
 
--- | 'fmap'ping a 'PatchMap' will alter all of the values it will insert.
--- Deletions are unaffected.
-instance Functor (PatchMap k) where
-  fmap f = PatchMap . fmap (fmap f) . unPatchMap
-
 -- | Returns all the new elements that will be added to the 'Map'
 patchMapNewElements :: PatchMap k v -> [v]
 patchMapNewElements (PatchMap p) = catMaybes $ Map.elems p

src/Data/Patch/MapWithMove.hs

@@ -1,18 +1,22 @@
-{-# LANGUAGE DeriveFoldable #-}
-{-# LANGUAGE DeriveFunctor #-}
 {-# LANGUAGE DeriveTraversable #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE PatternGuards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
+
 -- | 'Patch'es on 'Map' that can insert, delete, and move values from one key to
 -- another
 module Data.Patch.MapWithMove where
 
 import Data.Patch.Class
 
 import Control.Arrow
+import Control.Lens hiding (from, to)
 import Control.Monad.Trans.State
 import Data.Foldable
 import Data.Function
@@ -28,7 +32,13 @@ import Data.Tuple
 -- | Patch a Map with additions, deletions, and moves.  Invariant: If key @k1@
 -- is coming from @From_Move k2@, then key @k2@ should be going to @Just k1@,
 -- and vice versa.  There should never be any unpaired From/To keys.
-newtype PatchMapWithMove k v = PatchMapWithMove (Map k (NodeInfo k v)) deriving (Show, Eq, Ord, Functor, Foldable, Traversable)
+newtype PatchMapWithMove k v = PatchMapWithMove
+  { -- | Extract the internal representation of the 'PatchMapWithMove'
+    unPatchMapWithMove :: Map k (NodeInfo k v)
+  }
+  deriving ( Show, Read, Eq, Ord
+           , Functor, Foldable, Traversable
+           )
 
 -- | Holds the information about each key: where its new value should come from,
 -- and where its old value should go to
@@ -53,6 +63,13 @@ data From k v
 -- that means it will be deleted.
 type To = Maybe
 
+makeWrapped ''PatchMapWithMove
+
+instance FunctorWithIndex k (PatchMapWithMove k)
+instance FoldableWithIndex k (PatchMapWithMove k)
+instance TraversableWithIndex k (PatchMapWithMove k) where
+  itraverse f (PatchMapWithMove x) = PatchMapWithMove <$> itraverse (traverse . f) x
+
 -- | Create a 'PatchMapWithMove', validating it
 patchMapWithMove :: Ord k => Map k (NodeInfo k v) -> Maybe (PatchMapWithMove k v)
 patchMapWithMove m = if valid then Just $ PatchMapWithMove m else Nothing
@@ -70,10 +87,6 @@ patchMapWithMoveInsertAll m = PatchMapWithMove $ flip fmap m $ \v -> NodeInfo
   , _nodeInfo_to = Nothing
   }
 
--- | Extract the internal representation of the 'PatchMapWithMove'
-unPatchMapWithMove :: PatchMapWithMove k v -> Map k (NodeInfo k v)
-unPatchMapWithMove (PatchMapWithMove p) = p
-
 -- | Make a @'PatchMapWithMove' k v@ which has the effect of inserting or updating a value @v@ to the given key @k@, like 'Map.insert'.
 insertMapKey :: k -> v -> PatchMapWithMove k v
 insertMapKey k v = PatchMapWithMove . Map.singleton k $ NodeInfo (From_Insert v) Nothing