keys 3.0.4 → 3.12.5

raw patch · 7 files changed

Files

.travis.yml +0/−8
CHANGELOG.markdown +68/−0
LICENSE +1/−1
README.markdown +18/−0
cabal.project +5/−0
keys.cabal +40/−14
src/Data/Key.hs +609/−59

− .travis.yml

@@ -1,8 +0,0 @@-language: haskell-notifications:-  irc:-    channels:-      - "irc.freenode.org#haskell-lens"-    skip_join: true-    template:-      - "\x0313keys\x03/\x0306%{branch}\x03 \x0314%{commit}\x03 %{build_url} %{message}"

+ CHANGELOG.markdown view

@@ -0,0 +1,68 @@+3.12.5 [2026.01.10]+-------------------+* Use a more efficient implementation for `zipWithKey` in the `ZipWithKey`+  instance for `HashMap`.+* Remove unused `semigroups` and `transformers-compat` dependencies.++3.12.4 [2024.12.06]+-------------------+* Require building with GHC 8.0 or later.++3.12.3 [2020.01.29]+-------------------+* Add `Keyed`, `Indexable`, `Lookup`, `Adjustable`, `FoldableWithKey`, and+  `TraversableWithKey` instances for `Control.Applicative.Const` and+  `Data.Functor.Constant.Constant`.++3.12.2 [2019.05.02]+-------------------+* Use more efficient implementations of `lookup`, `adjust`, `foldMapWithKey`,+  and `traverseWithKey` if building against `containers-0.5.8` or later.++3.12.1 [2018.07.03]+-------------------+* Allow building with `containers-0.6`.+* Avoid the use of deprecated functions from `containers`.++3.12 [2018.01.28]+-----------------+* Add instances for data types in `GHC.Generics`. Change the existing instances+  for `Data.Functor.Sum` to be consistent with those for `(GHC.Generics.:+:)`.+* Add instances for `Proxy` and `Tagged`.+* Add instances for `ZipList`.+* Add `MINIMAL` sets for `Zip` and `FoldableWithKey`.+* Allow `free-5`.++3.11+----+* Support for `comonad` 5+* Support for GHC 8+* Support for `transformers` 0.5++3.10.2+------+* Support for `semigroupoids` 5++3.10.1+------+* Support for `transformers` 0.4++3.10+----+* Updated to use `free`, `semigroupoids`, `comonad` version 4.0++3.0.4+-----+* Updated array dependency+* Added proper upper bounds to other dependencies++3.0.3+-----+* This package is now `Trustworthy`++3.0.2+-----+* Removed upper bounds on my other dependencies+* Directory layout change+* Added support files+* Travis build notification to IRC

LICENSE view

@@ -1,4 +1,4 @@-Copyright 2011 Edward Kmett+Copyright 2011-2016 Edward Kmett  All rights reserved.

+ README.markdown view

@@ -0,0 +1,18 @@+keys+====++[![Hackage](https://img.shields.io/hackage/v/keys.svg)](https://hackage.haskell.org/package/keys) [![Build Status](https://github.com/ekmett/keys/workflows/Haskell-CI/badge.svg)](https://github.com/ekmett/keys/actions?query=workflow%3AHaskell-CI)++This package provides a bunch of ad hoc classes for accessing parts of a container.++In practice this package is largely subsumed by the `lens` package, but it is maintained for now+as it has much simpler dependencies.++Contact Information+-------------------++Contributions and bug reports are welcome!++Please feel free to contact me through github or on the #haskell IRC channel on irc.freenode.net.++-Edward Kmett

+ cabal.project view

@@ -0,0 +1,5 @@+packages: .++-- use local semigroupoids checkout if found+--  git clone https://github.com/ekmett/semigroupoids.git+optional-packages: semigroupoids/

keys.cabal view

@@ -1,38 +1,64 @@ name:          keys category:      Data Structures, Containers-version:       3.0.4+version:       3.12.5 license:       BSD3-cabal-version: >= 1.6+cabal-version: >= 1.10 license-file:  LICENSE author:        Edward A. Kmett maintainer:    Edward A. Kmett <ekmett@gmail.com> stability:     provisional homepage:      http://github.com/ekmett/keys/ bug-reports:   http://github.com/ekmett/keys/issues-copyright:     Copyright (C) 2011 Edward A. Kmett+copyright:     Copyright (C) 2011-2016 Edward A. Kmett synopsis:      Keyed functors and containers-description:   Keyed functors and containers+description:   This package provides a bunch of ad hoc classes for accessing parts of a container.+               .+               In practice this package is largely subsumed by the+               <https://hackage.haskell.org/package/lens lens package>,+               but it is maintained for now as it has much+               simpler dependencies.+ build-type:    Simple-extra-source-files: .travis.yml+extra-source-files: CHANGELOG.markdown README.markdown cabal.project+tested-with:   GHC == 9.14.1+             , GHC == 9.12.2+             , GHC == 9.10.3+             , GHC == 9.8.4+             , GHC == 9.6.7+             , GHC == 9.4.8+             , GHC == 9.2.8+             , GHC == 9.0.2+             , GHC == 8.10.7+             , GHC == 8.8.4+             , GHC == 8.6.5+             , GHC == 8.4.4+             , GHC == 8.2.2+             , GHC == 8.0.2  source-repository head   type: git-  location: git://github.com/ekmett/keys.git+  location: https://github.com/ekmett/keys.git  library+  default-language: Haskell2010+  other-extensions: CPP, FlexibleInstances, TypeOperators, TypeFamilies+   build-depends:     array                >= 0.3.0.2 && < 0.6,-    base                 >= 4       && < 5,-    containers           >= 0.3     && < 0.6,-    transformers         >= 0.2     && < 0.4,-    semigroups           >= 0.8.3.1 && < 1,-    semigroupoids        >= 3       && < 4,-    comonad-transformers >= 3       && < 4,-    comonads-fd          >= 3       && < 4,-    free                 >= 3       && < 4+    base                 >= 4.9     && < 5,+    comonad              >= 4       && < 6,+    containers           >= 0.3     && < 0.9,+    free                 >= 4       && < 6,+    hashable             >= 1.1.2.3 && < 1.6,+    semigroupoids        >= 5.2     && < 7,+    tagged               >= 0.7.3   && < 1,+    transformers         >= 0.5     && < 0.7,+    unordered-containers >= 0.2.6   && < 0.3    exposed-modules:     Data.Key    ghc-options: -Wall+  if impl(ghc >= 8.6)+    ghc-options: -Wno-star-is-type   hs-source-dirs: src

src/Data/Key.hs view

@@ -1,8 +1,8 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE CPP #-}-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE Trustworthy #-}-#endif+{-# LANGUAGE BangPatterns      #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeOperators     #-}+{-# LANGUAGE TypeFamilies      #-}+{-# LANGUAGE CPP               #-} module Data.Key (   -- * Keys     Key@@ -15,7 +15,7 @@   -- * Zippable functors   , Zip(..) -  -- * Zipping keyed functors +  -- * Zipping keyed functors   , ZipWithKey(..)    -- * Indexable functors@@ -59,7 +59,7 @@   , mapWithKeyDefault -- :: TraversableWithKey t => (Key t -> a -> b) -> t a -> t b   , foldMapWithKeyDefault -- :: (TraversableWithKey t, Monoid m) => (Key t -> a -> m) -> t a -> m -  -- * TraverableWithKey1+  -- * TraversableWithKey1   , TraversableWithKey1(..)   , foldMapWithKey1Default -- :: (TraversableWithKey1 t, Semigroup m) => (Key t -> a -> m) -> t a -> m   ) where@@ -75,35 +75,60 @@ import Data.Functor.Identity import Data.Functor.Bind import Data.Functor.Compose+import Data.Functor.Constant import Data.Functor.Product-import Data.Functor.Coproduct+import qualified Data.Functor.Sum as Functor import Data.Foldable+import Data.Hashable+import Data.HashMap.Lazy (HashMap)+import qualified Data.HashMap.Lazy as HashMap import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap import Data.Ix hiding (index) import Data.Map (Map) import qualified Data.Map as Map-import Data.Tree++#ifdef MIN_VERSION_base_orphans+import Data.Orphans ()+#endif+import Data.Proxy import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NonEmpty-import Data.Maybe (listToMaybe)+import Data.Maybe (fromJust, listToMaybe) import qualified Data.Monoid as Monoid import Data.Semigroup hiding (Product) import Data.Semigroup.Foldable import Data.Semigroup.Traversable import Data.Sequence (Seq, ViewL(EmptyL), viewl, (|>)) import qualified Data.Sequence as Seq+import Data.Tagged import Data.Traversable+import Data.Tree import qualified Data.List as List+import Data.Void+import GHC.Generics import Prelude hiding (lookup, zip, zipWith) --- TODO: half of the functions manipulating Cofree and Free buil the keys in the wrong order+-- TODO: half of the functions manipulating Cofree and Free build the keys in the wrong order -type family Key (f :: * -> *) +type family Key (f :: * -> *) type instance Key (Cofree f) = Seq (Key f) type instance Key (Free f) = Seq (Key f) type instance Key Tree = Seq Int type instance Key NonEmpty = Int+type instance Key U1 = Void+type instance Key V1 = Void+type instance Key Par1 = ()+type instance Key Proxy = Void+type instance Key (Tagged a) = ()+type instance Key (Const e) = Void+type instance Key (Constant e) = Void+type instance Key (g :.: f) = (Key g, Key f)+type instance Key (f :*: g) = Either (Key f) (Key g)+type instance Key (f :+: g) = Either (Key f) (Key g)+type instance Key (Rec1 f) = Key f+type instance Key (M1 i c f) = Key f+type instance Key (K1 i c) = Void  -- * Keyed class Functor f => Keyed f where@@ -119,6 +144,75 @@ instance Keyed Tree where   mapWithKey f (Node a as) = Node (f Seq.empty a) (mapWithKey (mapWithKey . fmap f . flip (|>)) as) +instance Keyed U1 where+  mapWithKey _ U1 = U1++instance Keyed V1 where+  mapWithKey _ v = v `seq` undefined++instance Keyed Par1 where+  mapWithKey q = fmap (q ())++instance Keyed (K1 i c) where+  mapWithKey _ (K1 c) = K1 c++instance Keyed (Tagged a) where+  mapWithKey q (Tagged a) = Tagged (q () a)++instance Keyed Proxy where+  mapWithKey _ Proxy = Proxy++instance Keyed (Const e) where+  mapWithKey _ (Const a) = Const a++instance Keyed (Constant e) where+  mapWithKey _ (Constant a) = Constant a++instance Keyed f => Keyed (M1 i c f) where+  mapWithKey q (M1 f) = M1 (mapWithKey q f)++instance Keyed f => Keyed (Rec1 f) where+  mapWithKey q (Rec1 f) = Rec1 (mapWithKey q f)++instance (Keyed g, Keyed f) => Keyed (f :*: g) where+  mapWithKey q (fa :*: ga) = mapWithKey (q . Left) fa :*: mapWithKey (q . Right) ga++instance (Keyed g, Keyed f) => Keyed (f :+: g) where+  mapWithKey q (L1 fa) = L1 (mapWithKey (q . Left) fa)+  mapWithKey q (R1 ga) = R1 (mapWithKey (q . Right) ga)++instance (Keyed g, Keyed f) => Keyed (g :.: f) where+  mapWithKey q = inComp (mapWithKey (mapWithKey . fmap q . (,)))++#if 0+mapWithKey :: (Key (g :.: f) -> a -> b) -> (g :.: f) a -> (g :.: f) b+           :: ((Key g, Key f) -> a -> b) -> (g :.: f) a -> (g :.: f) b++mapWithKey q+  = \ (Comp1 gfa) -> Comp1 (mapWithKey (\ gk -> mapWithKey (\ fk a -> q (gk, fk) a)) gfa)+  = inComp $ mapWithKey (\ gk -> mapWithKey (\ fk a -> q (gk, fk) a))+  = inComp $ mapWithKey (\ gk -> mapWithKey (\ fk -> q (gk, fk)))+  = inComp $ mapWithKey (\ gk -> mapWithKey (q . (gk,)))+  = inComp $ mapWithKey (\ gk -> mapWithKey . (q .) $ (gk,))+  = inComp $ mapWithKey (\ gk -> mapWithKey . (q .) $ (,) gk)+  = inComp (mapWithKey (mapWithKey . fmap q . (,)))++q   :: ((Key g, Key f) -> a -> b)+gfa :: g (f a)+gk  :: Key g+fk  :: Key f+#endif++-- |+--+-- Laws:+--+-- @+-- 'fmap' 'fst' ('zip' u u) = u+-- 'fmap' 'snd' ('zip' u u) = u+-- 'zip' ('fmap' 'fst' u) ('fmap' 'snd' u) = u+-- 'zip' ('flip' (,)) x y = 'zip' y x+-- @ class Functor f => Zip f where   zipWith :: (a -> b -> c) -> f a -> f b -> f c   zipWith f a b = uncurry f <$> zip a b@@ -130,12 +224,55 @@   zap :: f (a -> b) -> f a -> f b   zap = zipWith id +  {-# MINIMAL zipWith | zip #-}+ instance Zip f => Zip (Cofree f) where   zipWith f (a :< as) (b :< bs) = f a b :< zipWith (zipWith f) as bs  instance Zip Tree where   zipWith f (Node a as) (Node b bs) = Node (f a b) (zipWith (zipWith f) as bs) +instance Zip Proxy where+  zipWith = liftA2++instance Zip (Tagged a) where+  zipWith = liftA2++instance Zip U1 where+  zipWith = liftA2++instance Zip V1 where+  zipWith _ v = v `seq` undefined++instance Zip Par1 where+  zipWith = liftA2++instance (Zip f, Zip g) => Zip (f :*: g) where+  zipWith h (fa :*: ga) (fa' :*: ga') =+    zipWith h fa fa' :*: zipWith h ga ga'++instance (Zip f, Zip g) => Zip (g :.: f) where+  zipWith = inComp2 . zipWith . zipWith++instance Zip f => Zip (Rec1 f) where+  zipWith f (Rec1 a) (Rec1 b) = Rec1 (zipWith f a b)++instance Zip f => Zip (M1 i c f) where+  zipWith f (M1 a) (M1 b) = M1 (zipWith f a b)++-- | Add post- and pre-processing+(<--) :: (b -> b') -> (a' -> a) -> ((a -> b) -> (a' -> b'))+(h <-- f) g = h . g . f++-- | Apply a unary function within the 'Comp1' constructor.+inComp :: (g (f a) -> g' (f' a')) -> ((g :.: f) a -> (g' :.: f') a')+inComp = Comp1 <-- unComp1++-- | Apply a binary function within the 'Comp1' constructor.+inComp2 :: (  g (f a)   -> g' (f' a')     -> g'' (f'' a''))+        -> ((g :.: f) a -> (g' :.: f') a' -> (g'' :.: f'') a'')+inComp2 = inComp <-- unComp1+ class (Keyed f, Zip f) => ZipWithKey f where   zipWithKey :: (Key f -> a -> b -> c) -> f a -> f b -> f c   zipWithKey f = zap . mapWithKey f@@ -148,7 +285,34 @@  instance ZipWithKey Tree where   zipWithKey f (Node a as) (Node b bs) = f Seq.empty a b `Node` zipWithKey (zipWithKey . fmap f . flip (|>)) as bs-  ++instance ZipWithKey (Tagged a) where+  zipWithKey f = zipWith  (f ())++instance ZipWithKey Proxy where+  zipWithKey _ _ _ = Proxy++instance ZipWithKey U1 where+  zipWithKey _ _ _ = U1++instance ZipWithKey V1 where+  zipWithKey _ u v = u `seq` v `seq` undefined++instance ZipWithKey Par1 where+  zipWithKey f (Par1 a) (Par1 b) = Par1 (f () a b)++instance ZipWithKey f => ZipWithKey (Rec1 f) where+  zipWithKey f (Rec1 a) (Rec1 b) = Rec1 (zipWithKey f a b)++instance ZipWithKey f => ZipWithKey (M1 i c f) where+  zipWithKey f (M1 a) (M1 b) = M1 (zipWithKey f a b)++instance (ZipWithKey f, ZipWithKey g) => ZipWithKey (f :*: g) where+  zipWithKey f (as :*: bs) (cs :*: ds) = zipWithKey (f . Left) as cs :*: zipWithKey (f . Right) bs ds++instance (ZipWithKey f, ZipWithKey g) => ZipWithKey (g :.: f) where+  zipWithKey f (Comp1 xs) (Comp1 ys) = Comp1 $ zipWithKey (\a -> zipWithKey (\b -> f (a,b))) xs ys+ infixl 4 <#$>  (<#$>) :: Keyed f => (Key f -> a -> b) -> f a -> f b@@ -165,15 +329,51 @@   index :: f a -> Key f -> a  instance Indexable f => Indexable (Cofree f) where-  index (a :< as) key = case viewl key of +  index (a :< as) key = case viewl key of       EmptyL -> a       k Seq.:< ks -> index (index as k) ks +instance Indexable (Tagged a) where+  index (Tagged a) () = a++instance Indexable Proxy where+  index Proxy = absurd++instance Indexable (Const e) where+  index _ = absurd++instance Indexable (Constant e) where+  index _ = absurd+ instance Indexable Tree where-  index (Node a as) key = case viewl key of +  index (Node a as) key = case viewl key of       EmptyL -> a       k Seq.:< ks -> index (index as k) ks +instance Indexable U1 where+  index U1 = absurd++instance Indexable Par1 where+  index (Par1 a) () = a++instance Indexable f => Indexable (Rec1 f) where+  index (Rec1 f) a = index f a++instance Indexable f => Indexable (M1 i c f) where+  index (M1 f) a = index f a++instance Indexable (K1 i c) where+  index _ = absurd++instance (Indexable g, Indexable f) =>+         Indexable (f :*: g) where+  index (fa :*: _) (Left  fk) = fa ! fk+  index (_ :*: ga) (Right gk) = ga ! gk++instance (Indexable g, Indexable f) =>+         Indexable (g :.: f) where+  index (Comp1 gfa) (gk,fk) = gfa ! gk ! fk+ (!) :: Indexable f => f a -> Key f -> a (!) = index @@ -183,24 +383,56 @@   lookup :: Key f -> f a -> Maybe a  instance Lookup f => Lookup (Cofree f) where-  lookup key (a :< as) = case viewl key of +  lookup key (a :< as) = case viewl key of     EmptyL -> Just a     k Seq.:< ks -> lookup k as >>= lookup ks +instance Lookup (Tagged a) where+  lookup () (Tagged a) = Just a++instance Lookup Proxy where+  lookup _ _ = Nothing++instance Lookup (Const e) where+  lookup _ _ = Nothing++instance Lookup (Constant e) where+  lookup _ _ = Nothing+ instance Lookup Tree where-  lookup key (Node a as) = case viewl key of +  lookup key (Node a as) = case viewl key of     EmptyL -> Just a     k Seq.:< ks -> lookup k as >>= lookup ks  instance Lookup f => Lookup (Free f) where-  lookup key (Pure a) -    | Seq.null key = Just a +  lookup key (Pure a)+    | Seq.null key = Just a     | otherwise = Nothing-  lookup key (Free as) = case viewl key of +  lookup key (Free as) = case viewl key of     k Seq.:< ks -> lookup k as >>= lookup ks     _ -> Nothing-  -    ++instance Lookup U1 where+  lookup _ _ = Nothing++instance Lookup Par1 where+  lookup = lookupDefault++instance Lookup f => Lookup (Rec1 f) where+  lookup k (Rec1 f) = lookup k f++instance Lookup f => Lookup (M1 i c f) where+  lookup k (M1 f) = lookup k f++instance Lookup (K1 i c) where+  lookup _ _ = Nothing++instance (Indexable g, Indexable f) => Lookup (f :*: g) where+  lookup = lookupDefault++instance (Indexable g, Indexable f) => Lookup (g :.: f) where+  lookup = lookupDefault+ lookupDefault :: Indexable f => Key f -> f a -> Maybe a lookupDefault k t = Just (index t k) @@ -213,8 +445,8 @@   replace k v = adjust (const v) k  instance Adjustable f => Adjustable (Free f) where-  adjust f key as@(Pure a) -    | Seq.null key = Pure $ f a +  adjust f key as@(Pure a)+    | Seq.null key = Pure $ f a     | otherwise = as   adjust f key aas@(Free as) = case viewl key of     k Seq.:< ks -> Free $ adjust (adjust f ks) k as@@ -230,6 +462,60 @@     k Seq.:< ks -> a   `Node` adjust (adjust f ks) k as     _           -> f a `Node` as +instance Adjustable (Tagged a) where+  adjust f _ (Tagged a) = Tagged (f a)+  replace _ a _ = Tagged a++instance Adjustable Proxy where+  adjust _ _ _ = Proxy+  replace _ _ _ = Proxy++instance Adjustable (Const e) where+  adjust _ _ x = x+  replace _ _ x = x++instance Adjustable (Constant e) where+  adjust _ _ x = x+  replace _ _ x = x++instance Adjustable U1 where+  adjust _ _ _ = U1+  replace _ _ _ = U1++instance Adjustable Par1 where+  adjust h () = fmap h+  replace _ a _ = Par1 a++instance Adjustable f => Adjustable (Rec1 f) where+  adjust f k (Rec1 a) = Rec1 (adjust f k a)+  replace k a (Rec1 b) = Rec1 (replace k a b)++instance Adjustable f => Adjustable (M1 i c f) where+  adjust f k (M1 a) = M1 (adjust f k a)+  replace k a (M1 b) = M1 (replace k a b)++instance Adjustable (K1 i c) where+  adjust _ _ x = x+  replace _ _ x = x++instance (Adjustable f, Adjustable g) => Adjustable (f :+: g) where+  adjust h (Left a) (L1 fa) = L1 (adjust h a fa)+  adjust h (Right b) (R1 fb) = R1 (adjust h b fb)+  adjust _ _ x = x+  replace (Left a) v (L1 fa) = L1 (replace a v fa)+  replace (Right b) v (R1 fb) = R1 (replace b v fb)+  replace _ _ x = x++instance (Adjustable f, Adjustable g) => Adjustable (f :*: g) where+  adjust h (Left  fk) (fa :*: ga) = adjust h fk fa :*: ga+  adjust h (Right gk) (fa :*: ga) = fa :*: adjust h gk ga+  replace (Left  fk) a (fa :*: ga) = replace fk a fa :*: ga+  replace (Right gk) a (fa :*: ga) = fa :*: replace gk a ga++instance (Adjustable f, Adjustable g) => Adjustable (g :.: f) where+  adjust h (gk,fk) = inComp (adjust (adjust h fk) gk)+  replace (gk,fk) a = inComp (adjust (replace fk a) gk)+ -- * FoldableWithKey  class Foldable t => FoldableWithKey t where@@ -245,6 +531,8 @@   foldlWithKey :: (b -> Key t -> a -> b) -> b -> t a -> b   foldlWithKey f z t = appEndo (getDual (foldMapWithKey (\k a -> Dual (Endo (\b -> f b k a))) t)) z +  {-# MINIMAL foldMapWithKey | foldrWithKey #-}+ instance FoldableWithKey f => FoldableWithKey (Free f) where   foldMapWithKey f (Pure a) = f Seq.empty a   foldMapWithKey f (Free as) = foldMapWithKey (foldMapWithKey . fmap f . flip (|>)) as@@ -252,9 +540,46 @@ instance FoldableWithKey f => FoldableWithKey (Cofree f) where   foldMapWithKey f (a :< as) = f Seq.empty a `mappend` foldMapWithKey (foldMapWithKey . fmap f . flip (|>)) as +instance FoldableWithKey (Tagged a) where+  foldMapWithKey f (Tagged a) = f () a++instance FoldableWithKey Proxy where+  foldMapWithKey _ _ = mempty++instance FoldableWithKey (Const e) where+  foldMapWithKey _ _ = mempty++instance FoldableWithKey (Constant e) where+  foldMapWithKey _ _ = mempty+ instance FoldableWithKey Tree where   foldMapWithKey f (Node a as) = f Seq.empty a `mappend` foldMapWithKey (foldMapWithKey . fmap f . flip (|>)) as +instance FoldableWithKey Par1 where+  foldMapWithKey f (Par1 a) = f () a++instance (FoldableWithKey f, FoldableWithKey g) => FoldableWithKey (f :*: g) where+  foldMapWithKey f (a :*: b) = foldMapWithKey (f . Left) a `mappend` foldMapWithKey (f . Right) b++instance (FoldableWithKey f, FoldableWithKey g) => FoldableWithKey (f :+: g) where+  foldMapWithKey f (L1 a) = foldMapWithKey (f . Left) a+  foldMapWithKey f (R1 a) = foldMapWithKey (f . Right) a++instance FoldableWithKey U1 where+  foldMapWithKey _ _ = mempty++instance FoldableWithKey V1 where+  foldMapWithKey _ v = v `seq` undefined++instance FoldableWithKey (K1 i c) where+  foldMapWithKey _ _ = mempty++instance FoldableWithKey f => FoldableWithKey (M1 i c f) where+  foldMapWithKey f (M1 a) = foldMapWithKey f a++instance FoldableWithKey f => FoldableWithKey (Rec1 f) where+  foldMapWithKey f (Rec1 a) = foldMapWithKey f a+ foldrWithKey' :: FoldableWithKey t => (Key t -> a -> b -> b) -> b -> t a -> b foldrWithKey' f z0 xs = foldlWithKey f' id xs z0   where f' k key x z = k $! f key x z@@ -326,7 +651,29 @@ instance FoldableWithKey1 f => FoldableWithKey1 (Free f) where   foldMapWithKey1 f (Pure a) = f Seq.empty a   foldMapWithKey1 f (Free as) = foldMapWithKey1 (foldMapWithKey1 . fmap f . flip (|>)) as-  ++instance FoldableWithKey1 (Tagged a) where+  foldMapWithKey1 f (Tagged a) = f () a++instance (FoldableWithKey1 f, FoldableWithKey1 g) => FoldableWithKey1 (f :*: g) where+  foldMapWithKey1 f (a :*: b) = foldMapWithKey1 (f . Left) a <> foldMapWithKey1 (f . Right) b++instance (FoldableWithKey1 f, FoldableWithKey1 g) => FoldableWithKey1 (f :+: g) where+  foldMapWithKey1 f (L1 a) = foldMapWithKey1 (f . Left) a+  foldMapWithKey1 f (R1 a) = foldMapWithKey1 (f . Right) a++instance FoldableWithKey1 V1 where+  foldMapWithKey1 _ v = v `seq` undefined++instance FoldableWithKey1 Par1 where+  foldMapWithKey1 f (Par1 a) = f () a++instance FoldableWithKey1 f => FoldableWithKey1 (M1 i c f) where+  foldMapWithKey1 f (M1 a) = foldMapWithKey1 f a++instance FoldableWithKey1 f => FoldableWithKey1 (Rec1 f) where+  foldMapWithKey1 f (Rec1 a) = foldMapWithKey1 f a+ newtype Act f a = Act { getAct :: f a }  instance Apply f => Semigroup (Act f a) where@@ -354,8 +701,20 @@   traverseWithKey :: Applicative f => (Key t -> a -> f b) -> t a -> f (t b)    mapWithKeyM :: Monad m => (Key t -> a -> m b) -> t a -> m (t b)-  mapWithKeyM f = unwrapMonad . traverseWithKey (fmap WrapMonad . f) +  mapWithKeyM f = unwrapMonad . traverseWithKey (fmap WrapMonad . f) +instance TraversableWithKey (Tagged a) where+  traverseWithKey f (Tagged a) = Tagged <$> f () a++instance TraversableWithKey Proxy where+  traverseWithKey _ _ = pure Proxy++instance TraversableWithKey (Const e) where+  traverseWithKey _ (Const a) = pure (Const a)++instance TraversableWithKey (Constant e) where+  traverseWithKey _ (Constant a) = pure (Constant a)+ instance TraversableWithKey f => TraversableWithKey (Cofree f) where   traverseWithKey f (a :< as) = (:<) <$> f Seq.empty a <*> traverseWithKey (traverseWithKey . fmap f . flip (|>)) as @@ -366,6 +725,31 @@   traverseWithKey f (Pure a) = Pure <$> f Seq.empty a   traverseWithKey f (Free as) = Free <$> traverseWithKey (traverseWithKey . fmap f . flip (|>)) as +instance (TraversableWithKey f, TraversableWithKey g) => TraversableWithKey (f :*: g) where+  traverseWithKey f (a :*: b) = (:*:) <$> traverseWithKey (f . Left) a <*> traverseWithKey (f . Right) b++instance (TraversableWithKey f, TraversableWithKey g) => TraversableWithKey (f :+: g) where+  traverseWithKey f (L1 as) = L1 <$> traverseWithKey (f . Left) as+  traverseWithKey f (R1 bs) = R1 <$> traverseWithKey (f . Right) bs++instance TraversableWithKey Par1 where+  traverseWithKey f (Par1 a) = Par1 <$> f () a++instance TraversableWithKey U1 where+  traverseWithKey _ U1 = pure U1++instance TraversableWithKey V1 where+  traverseWithKey _ v = v `seq` undefined++instance TraversableWithKey (K1 i c) where+  traverseWithKey _ (K1 p) = pure (K1 p)++instance TraversableWithKey f => TraversableWithKey (Rec1 f) where+  traverseWithKey f (Rec1 a) = Rec1 <$> traverseWithKey f a++instance TraversableWithKey f => TraversableWithKey (M1 i c f) where+  traverseWithKey f (M1 a) = M1 <$> traverseWithKey f a+ forWithKey :: (TraversableWithKey t, Applicative f) => t a -> (Key t -> a -> f b) -> f (t b) forWithKey = flip traverseWithKey {-# INLINE forWithKey #-}@@ -428,10 +812,13 @@ foldMapWithKeyDefault f = getConst . traverseWithKey (fmap Const . f) {-# INLINE foldMapWithKeyDefault #-} --- * TraverableWithKey1+-- * TraversableWithKey1 class (Traversable1 t, FoldableWithKey1 t, TraversableWithKey t) => TraversableWithKey1 t where   traverseWithKey1 :: Apply f => (Key t -> a -> f b) -> t a -> f (t b) +instance TraversableWithKey1 (Tagged a) where+  traverseWithKey1 f (Tagged a) = Tagged <$> f () a+ -- instance TraversableWithKey f => TraversableWithKey1 (Cofree f) where instance TraversableWithKey1 f => TraversableWithKey1 (Cofree f) where   traverseWithKey1 f (a :< as) = (:<) <$> f Seq.empty a <.> traverseWithKey1 (traverseWithKey1 . fmap f . flip (|>)) as@@ -439,11 +826,30 @@ instance TraversableWithKey1 Tree where   traverseWithKey1 f (Node a []) = (`Node`[]) <$> f Seq.empty a   traverseWithKey1 f (Node a (x:xs)) = (\b (y:|ys) -> Node b (y:ys)) <$> f Seq.empty a <.> traverseWithKey1 (traverseWithKey1 . fmap f . flip (|>)) (x:|xs)-  + instance TraversableWithKey1 f => TraversableWithKey1 (Free f) where   traverseWithKey1 f (Pure a) = Pure <$> f Seq.empty a   traverseWithKey1 f (Free as) = Free <$> traverseWithKey1 (traverseWithKey1 . fmap f . flip (|>)) as +instance TraversableWithKey1 Par1 where+  traverseWithKey1 f (Par1 a) = Par1 <$> f () a++instance TraversableWithKey1 f => TraversableWithKey1 (Rec1 f) where+  traverseWithKey1 f (Rec1 a) = Rec1 <$> traverseWithKey1 f a++instance TraversableWithKey1 f => TraversableWithKey1 (M1 i c f) where+  traverseWithKey1 f (M1 a) = M1 <$> traverseWithKey1 f a++instance TraversableWithKey1 V1 where+  traverseWithKey1 _ v = v `seq` undefined++instance (TraversableWithKey1 f, TraversableWithKey1 g) => TraversableWithKey1 (f :*: g) where+  traverseWithKey1 f (a :*: b) = (:*:) <$> traverseWithKey1 (f . Left) a <.> traverseWithKey1 (f . Right) b++instance (TraversableWithKey1 f, TraversableWithKey1 g) => TraversableWithKey1 (f :+: g) where+  traverseWithKey1 f (L1 as) = L1 <$> traverseWithKey1 (f . Left) as+  traverseWithKey1 f (R1 bs) = R1 <$> traverseWithKey1 (f . Right) bs+ foldMapWithKey1Default :: (TraversableWithKey1 t, Semigroup m) => (Key t -> a -> m) -> t a -> m foldMapWithKey1Default f = getConst . traverseWithKey1 (\k -> Const . f k) {-# INLINE foldMapWithKey1Default #-}@@ -498,7 +904,7 @@   zipWithKey f (IdentityT m) (IdentityT n) = IdentityT (zipWithKey f m n)  instance Keyed m => Keyed (IdentityT m) where-  mapWithKey f = IdentityT . mapWithKey f . runIdentityT +  mapWithKey f = IdentityT . mapWithKey f . runIdentityT  instance FoldableWithKey m => FoldableWithKey (IdentityT m) where   foldrWithKey f z (IdentityT m) = foldrWithKey f z m@@ -525,18 +931,18 @@  instance Indexable ((->)a) where   index = id-  + instance Lookup ((->)a) where   lookup i f = Just (f i)  type instance Key (ReaderT e m) = (e, Key m)  instance Zip m => Zip (ReaderT e m) where-  zipWith f (ReaderT m) (ReaderT n) = ReaderT $ \a -> +  zipWith f (ReaderT m) (ReaderT n) = ReaderT $ \a ->     zipWith f (m a) (n a)  instance ZipWithKey m => ZipWithKey (ReaderT e m) where-  zipWithKey f (ReaderT m) (ReaderT n) = ReaderT $ \a -> +  zipWithKey f (ReaderT m) (ReaderT n) = ReaderT $ \a ->     zipWithKey (f . (,) a) (m a) (n a)  instance Keyed m => Keyed (ReaderT e m) where@@ -551,22 +957,22 @@ type instance Key (TracedT s w) = (s, Key w)  instance Zip w => Zip (TracedT s w) where-  zipWith f (TracedT u) (TracedT v) = TracedT $ +  zipWith f (TracedT u) (TracedT v) = TracedT $     zipWith (\a b s -> f (a s) (b s)) u v  instance ZipWithKey w => ZipWithKey (TracedT s w) where-  zipWithKey f (TracedT u) (TracedT v) = TracedT $ +  zipWithKey f (TracedT u) (TracedT v) = TracedT $     zipWithKey (\k a b s -> f (s, k) (a s) (b s)) u v  instance Keyed w => Keyed (TracedT s w) where-  mapWithKey f = TracedT . mapWithKey (\k' g k -> f (k, k') (g k)) . runTracedT +  mapWithKey f = TracedT . mapWithKey (\k' g k -> f (k, k') (g k)) . runTracedT  instance Indexable w => Indexable (TracedT s w) where-  index (TracedT w) (e,k) = index w k e +  index (TracedT w) (e,k) = index w k e  instance Lookup w => Lookup (TracedT s w) where   lookup (e,k) (TracedT w) = ($ e) <$> lookup k w-  + type instance Key IntMap = Int  instance Zip IntMap where@@ -579,7 +985,11 @@   mapWithKey = IntMap.mapWithKey  instance FoldableWithKey IntMap where+#if MIN_VERSION_containers(0,5,0)+  foldrWithKey = IntMap.foldrWithKey+#else   foldrWithKey = IntMap.foldWithKey+#endif  instance TraversableWithKey IntMap where   traverseWithKey f = fmap IntMap.fromDistinctAscList . traverse (\(k, v) -> (,) k <$> f k v) . IntMap.toAscList@@ -599,7 +1009,7 @@   zipWith f (Compose a) (Compose b) = Compose $ zipWith (zipWith f) a b  instance (ZipWithKey f, ZipWithKey g) => ZipWithKey (Compose f g) where-  zipWithKey f (Compose a) (Compose b) = Compose $ +  zipWithKey f (Compose a) (Compose b) = Compose $     zipWithKey (zipWithKey . fmap f . (,)) a b  instance (Keyed f, Keyed g) => Keyed (Compose f g) where@@ -634,7 +1044,7 @@     go _ [] _ = []     go _ _ [] = []     go n (x:xs) (y:ys) = n' `seq` f n x y : go n' xs ys-      where n' = n + 1 +      where n' = n + 1  instance Keyed [] where   mapWithKey f xs0 = go xs0 0 where@@ -662,8 +1072,33 @@   adjust _ _ [] = []   adjust f n (x:xs) = n' `seq` x : adjust f n' xs where n' = n - 1 +type instance Key ZipList = Int +instance Zip ZipList where+  zip       (ZipList xs) (ZipList ys) = ZipList (zip xs ys)+  zipWith f (ZipList xs) (ZipList ys) = ZipList (zipWith f xs ys) +instance ZipWithKey ZipList where+  zipWithKey f (ZipList xs) (ZipList ys) = ZipList (zipWithKey f xs ys)++instance Keyed ZipList where+  mapWithKey f = ZipList . mapWithKey f . getZipList++instance FoldableWithKey ZipList where+  foldrWithKey f z = foldrWithKey f z . getZipList++instance TraversableWithKey ZipList where+  traverseWithKey f = fmap ZipList . traverseWithKey f . getZipList++instance Indexable ZipList where+  index (ZipList xs) i = index xs i++instance Lookup ZipList where+  lookup i = lookup i . getZipList++instance Adjustable ZipList where+  adjust f i = ZipList . adjust f i . getZipList+ instance Zip NonEmpty where   zipWith = NonEmpty.zipWith @@ -692,7 +1127,7 @@   adjust f n (x:|xs) = x :| adjust f (n - 1) xs  instance FoldableWithKey1 NonEmpty where-  foldMapWithKey1 f (x:|[]) = f 0 x +  foldMapWithKey1 f (x:|[]) = f 0 x   foldMapWithKey1 f (x:|(y:ys)) = f 0 x <> foldMapWithKey1 (f . (+1)) (y:|ys) -- TODO optimize  instance TraversableWithKey1 NonEmpty where@@ -705,9 +1140,14 @@   index = Seq.index  instance Lookup Seq where-  lookup i s = case viewl (Seq.drop i s) of-    EmptyL -> Nothing-    a Seq.:< _ -> Just a+  lookup i s =+#if MIN_VERSION_containers(0,5,8)+    Seq.lookup i s+#else+    case viewl (Seq.drop i s) of+      EmptyL -> Nothing+      a Seq.:< _ -> Just a+#endif  instance Zip Seq where   zip = Seq.zip@@ -717,16 +1157,35 @@   zipWithKey f a b = Seq.zipWith id (Seq.mapWithIndex f a) b  instance Adjustable Seq where-  adjust = Seq.adjust +  adjust f i xs =+#if MIN_VERSION_containers(0,5,8)+    Seq.adjust' f i xs -- Use the prefered strict version when available+#else+    -- Otherwise use a custom adjustment in place of the inefficient Seq.adjust+    case i `lookup` xs of+      Nothing -> xs+      Just x  -> let !x' = f x+                 in  Seq.update i x' xs+#endif+ instance Keyed Seq where   mapWithKey = Seq.mapWithIndex  instance FoldableWithKey Seq where   foldrWithKey = Seq.foldrWithIndex+  foldlWithKey = Seq.foldlWithIndex+#if MIN_VERSION_containers(0,5,8)+  foldMapWithKey = Seq.foldMapWithIndex+#endif  instance TraversableWithKey Seq where-  traverseWithKey f = fmap Seq.fromList . traverseWithKey f . toList+  traverseWithKey f =+#if MIN_VERSION_containers(0,5,8)+    Seq.traverseWithIndex f+#else+    fmap Seq.fromList . traverseWithKey f . toList+#endif  type instance Key (Map k) = k @@ -755,10 +1214,10 @@   adjust = Map.adjust  type instance Key (Array i) = i-  + instance Ix i => Keyed (Array i) where   mapWithKey f arr = Array.listArray (Array.bounds arr) $ map (uncurry f) $ Array.assocs arr-  + -- a pleasant fiction instance Ix i => Indexable (Array i) where   index = (Array.!)@@ -777,28 +1236,56 @@ instance Ix i => Adjustable (Array i) where   adjust f i arr  = arr Array.// [(i, f (arr Array.! i))]   replace i b arr = arr Array.// [(i, b)]-  -type instance Key (Coproduct f g) = (Key f, Key g) -instance (Indexable f, Indexable g) => Indexable (Coproduct f g) where-  index (Coproduct (Left a)) (x,_) = index a x -  index (Coproduct (Right b)) (_,y) = index b y+type instance Key (Functor.Sum f g) = Either (Key f) (Key g) -instance (Lookup f, Lookup g) => Lookup (Coproduct f g) where-  lookup (x, _) (Coproduct (Left a)) = lookup x a-  lookup (_, y) (Coproduct (Right b)) = lookup y b+instance (Keyed f, Keyed g) => Keyed (Functor.Sum f g) where+  mapWithKey f (Functor.InL a) = Functor.InL (mapWithKey (f . Left)  a)+  mapWithKey f (Functor.InR b) = Functor.InR (mapWithKey (f . Right) b) -instance (Adjustable f, Adjustable g) => Adjustable (Coproduct f g) where-  adjust f (x,_) (Coproduct (Left a)) = Coproduct (Left (adjust f x a))-  adjust f (_,y) (Coproduct (Right b)) = Coproduct (Right (adjust f y b))+instance (Indexable f, Indexable g) => Indexable (Functor.Sum f g) where+  index (Functor.InL a) (Left  x) = index a x+  index (Functor.InL _) (Right _) = error "InL indexed with a Right key"+  index (Functor.InR b) (Right y) = index b y+  index (Functor.InR _) (Left  _) = error "InR indexed with a Left key" +instance (Lookup f, Lookup g) => Lookup (Functor.Sum f g) where+  lookup (Left  x) (Functor.InL a) = lookup x a+  lookup (Right y) (Functor.InR b) = lookup y b+  lookup _         _               = Nothing++instance (Adjustable f, Adjustable g) => Adjustable (Functor.Sum f g) where+  adjust f (Left  x) (Functor.InL a) = Functor.InL (adjust f x a)+  adjust f (Right y) (Functor.InR b) = Functor.InR (adjust f y b)+  adjust _ _         x               = x++  replace (Left  x) v (Functor.InL a) = Functor.InL (replace x v a)+  replace (Right y) v (Functor.InR b) = Functor.InR (replace y v b)+  replace _         _ x               = x++instance (FoldableWithKey f, FoldableWithKey g) => FoldableWithKey (Functor.Sum f g) where+  foldMapWithKey f (Functor.InL a) = foldMapWithKey (f . Left)  a+  foldMapWithKey f (Functor.InR b) = foldMapWithKey (f . Right) b++instance (FoldableWithKey1 f, FoldableWithKey1 g) => FoldableWithKey1 (Functor.Sum f g) where+  foldMapWithKey1 f (Functor.InL a) = foldMapWithKey1 (f . Left)  a+  foldMapWithKey1 f (Functor.InR b) = foldMapWithKey1 (f . Right) b++instance (TraversableWithKey f, TraversableWithKey g) => TraversableWithKey (Functor.Sum f g) where+  traverseWithKey f (Functor.InL a) = Functor.InL <$> traverseWithKey (f . Left)  a+  traverseWithKey f (Functor.InR b) = Functor.InR <$> traverseWithKey (f . Right) b++instance (TraversableWithKey1 f, TraversableWithKey1 g) => TraversableWithKey1 (Functor.Sum f g) where+  traverseWithKey1 f (Functor.InL a) = Functor.InL <$> traverseWithKey1 (f . Left)  a+  traverseWithKey1 f (Functor.InR b) = Functor.InR <$> traverseWithKey1 (f . Right) b+ type instance Key (Product f g) = Either (Key f) (Key g)  instance (Keyed f, Keyed g) => Keyed (Product f g) where   mapWithKey f (Pair a b) = Pair (mapWithKey (f . Left) a) (mapWithKey (f . Right) b)  instance (Indexable f, Indexable g) => Indexable (Product f g) where-  index (Pair a _) (Left i)  = index a i +  index (Pair a _) (Left i)  = index a i   index (Pair _ b) (Right j) = index b j  instance (Lookup f, Lookup g) => Lookup (Product f g) where@@ -830,3 +1317,66 @@   replace (Left i) v (Pair a b) = Pair (replace i v a) b   replace (Right j) v (Pair a b) = Pair a (replace j v b) +type instance Key ((,) k) = k++instance Keyed ((,) k) where+  mapWithKey f (k, a) = (k, f k a)++instance FoldableWithKey ((,) k) where+  foldMapWithKey = uncurry++instance FoldableWithKey1 ((,) k) where+  foldMapWithKey1 = uncurry++instance TraversableWithKey ((,) k) where+  traverseWithKey f (k, a) = (,) k <$> f k a++instance TraversableWithKey1 ((,) k) where+  traverseWithKey1 f (k, a) = (,) k <$> f k a++type instance Key (HashMap k) = k++instance Keyed (HashMap k) where+  mapWithKey = HashMap.mapWithKey++instance (Eq k, Hashable k) => Indexable (HashMap k) where+  index = (HashMap.!)++instance (Eq k, Hashable k) => Lookup (HashMap k) where+  lookup = HashMap.lookup++instance (Eq k, Hashable k) => Zip (HashMap k) where+  zipWith = HashMap.intersectionWith++instance (Eq k, Hashable k) => ZipWithKey (HashMap k) where+  zipWithKey = HashMap.intersectionWithKey++instance FoldableWithKey (HashMap k) where+  foldrWithKey = HashMap.foldrWithKey++instance TraversableWithKey (HashMap k) where+  traverseWithKey = HashMap.traverseWithKey++type instance Key Maybe = ()++instance Keyed Maybe where+  mapWithKey f = fmap (f ())++instance Indexable Maybe where+  index = const . fromJust++instance Lookup Maybe where+  lookup _ mb = mb++instance Zip Maybe where+  zipWith f (Just a) (Just b) = Just (f a b)+  zipWith _ _        _        = error "zipWith: Nothing"++instance ZipWithKey Maybe where+  zipWithKey f = zipWith (f ())++instance FoldableWithKey Maybe where+  foldMapWithKey f = foldMap (f ())++instance TraversableWithKey Maybe where+  traverseWithKey f = traverse (f ())