Merge pull request #12 from reflex-frp/add-WithIndex-instances

Add *WithIndex instances

ChangeLog.md

@@ -1,5 +1,17 @@
 # Revision history for patch
 
+## Unreleased
+
+* Consistently provide:
+
+   - `Wrapped` instances
+
+   - `*WithIndex` instances
+
+   - `un*` newtype unwrappers
+
+  for `PatchMap`, `PatchIntMap`, and `PatchMapWithMove`.
+
 ## 0.0.1.0
 
 * Support older GHCs with `split-these` flag.

dep/reflex-platform/default.nix

@@ -1,7 +1,8 @@
 # DO NOT HAND-EDIT THIS FILE
-import ((import <nixpkgs> {}).fetchFromGitHub (
-  let json = builtins.fromJSON (builtins.readFile ./github.json);
-  in { inherit (json) owner repo rev sha256;
-       private = json.private or false;
-     }
-))
+let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256, ... }:
+  if !fetchSubmodules && !private then builtins.fetchTarball {
+    url = "https://github.com/${owner}/${repo}/archive/${rev}.tar.gz"; inherit sha256;
+  } else (import <nixpkgs> {}).fetchFromGitHub {
+    inherit owner repo rev sha256 fetchSubmodules private;
+  };
+in import (fetch (builtins.fromJSON (builtins.readFile ./github.json)))

dep/reflex-platform/github.json

@@ -2,6 +2,7 @@
   "owner": "reflex-frp",
   "repo": "reflex-platform",
   "branch": "master",
-  "rev": "510b990d0b11f0626afbec5fe8575b5b2395391b",
-  "sha256": "09cmahsbxr0963wq171c7j139iyzz49hramr4v9nsf684wcwkngv"
+  "private": false,
+  "rev": "c9d11db1b98855fe8ab24a3ff6a5dbe0ad902ad9",
+  "sha256": "0sfzkqdvyah5mwvmli0wq1nl0b8cvk2cmfgfy4rz57wv42x3099y"
 }

patch.cabal

@@ -35,6 +35,7 @@ library
                , containers >= 0.6 && < 0.7
                , dependent-map >= 0.3 && < 0.4
                , dependent-sum >= 0.6 && < 0.7
+               , lens >= 4.7 && < 5
                , semigroupoids >= 4.0 && < 6
                , transformers >= 0.5.6.0 && < 0.6
                , witherable >= 0.3 && < 0.3.2

release.nix

@@ -18,16 +18,26 @@ let
       "ghcIosAarch64"
     ];
     compilerPkgs = lib.genAttrs compilers (ghc: let
-      src = builtins.filterSource (path: type: !(builtins.elem (baseNameOf path) [
-        "release.nix"
-        ".git"
-        "dist"
-        "dist-newstyle"
-        "cabal.haskell-ci"
-        "cabal.project"
-        ".travis.yml"
-      ])) ./.;
-    in reflex-platform.${ghc}.callCabal2nix "patch" src {});
+      reflex-platform = reflex-platform-fun {
+        inherit system;
+        haskellOverlays = [
+          # Use this package's source for reflex
+          (self: super: {
+            _dep = super._dep // {
+              patch = builtins.filterSource (path: type: !(builtins.elem (baseNameOf path) [
+                "release.nix"
+                ".git"
+                "dist"
+                "dist-newstyle"
+                "cabal.haskell-ci"
+                "cabal.project"
+                ".travis.yml"
+              ])) ./.;
+            };
+          })
+        ];
+      };
+    in reflex-platform.${ghc}.patch);
   in compilerPkgs // {
     cache = reflex-platform.pinBuildInputs "patch-${system}"
       (builtins.attrValues compilerPkgs);

src/Data/Patch/IntMap.hs

@@ -1,12 +1,15 @@
-{-# 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
 
+import Control.Lens
 import Data.IntMap.Strict (IntMap)
 import qualified Data.IntMap.Strict as IntMap
 import Data.Maybe
@@ -16,7 +19,20 @@ 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
+-- 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
+
+makeWrapped ''PatchIntMap
 
 -- | Apply the insertions or deletions to a given 'IntMap'.
 instance Patch (PatchIntMap a) where
@@ -26,13 +42,10 @@ instance Patch (PatchIntMap a) where
         adds = IntMap.mapMaybe id p
     in IntMap.union adds $ v `IntMap.difference` removes
 
--- | @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
+instance FunctorWithIndex Int PatchIntMap
+instance FoldableWithIndex Int PatchIntMap
+instance TraversableWithIndex Int PatchIntMap where
+  itraversed = _Wrapped . itraversed . traversed
 
 -- | Map a function @Int -> a -> b@ over all @a@s in the given @'PatchIntMap' a@
 -- (that is, all inserts/updates), producing a @PatchIntMap b@.

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