diff --git a/.travis.yml b/.travis.yml
--- a/.travis.yml
+++ b/.travis.yml
@@ -1,1 +1,8 @@
 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}"
diff --git a/Data/Key.hs b/Data/Key.hs
deleted file mode 100644
--- a/Data/Key.hs
+++ /dev/null
@@ -1,828 +0,0 @@
-{-# LANGUAGE TypeFamilies #-}
-module Data.Key (
-  -- * Keys
-    Key
-
-  -- * Keyed functors
-  , Keyed(..)
-  , (<#$>) -- :: Keyed f => (Key f -> a -> b) -> f a -> f b
-  , keyed -- :: Keyed f => f a -> f (Key f, a)
-
-  -- * Zippable functors
-  , Zip(..)
-
-  -- * Zipping keyed functors 
-  , ZipWithKey(..)
-
-  -- * Indexable functors
-  , Indexable(..)
-  , (!)
-
-  -- * Safe Lookup
-  , Lookup(..)
-  , lookupDefault
-
-  -- * Adjustable
-  , Adjustable(..)
-
-  -- * FoldableWithKey
-  , FoldableWithKey(..)
-  , foldrWithKey' -- :: FoldableWithKey t => (Key t -> a -> b -> b) -> b -> t a -> b
-  , foldlWithKey' -- :: FoldableWithKey t => (b -> Key t -> a -> b) -> b -> t a -> b
-  , foldrWithKeyM -- :: (FoldableWithKey t, Monad m) => (Key t -> a -> b -> m b) -> b -> t a -> m b
-  , foldlWithKeyM -- :: (FoldableWithKey t, Monad m) => (b -> Key t -> a -> m b) -> b -> t a -> m b
-  , traverseWithKey_ -- :: (FoldableWithKey t, Applicative f) => (Key t -> a -> f b) -> t a -> f ()
-  , forWithKey_ -- :: (FoldableWithKey t, Applicative f) => t a -> (Key t -> a -> f b) -> f ()
-  , mapWithKeyM_ -- :: (FoldableWithKey t, Monad m) => (Key t -> a -> m b) -> t a -> m ()
-  , forWithKeyM_ -- :: (FoldableWithKey t, Monad m) => t a -> (Key t -> a -> m b) -> m ()
-  , concatMapWithKey -- :: FoldableWithKey t => (Key t -> a -> [b]) -> t a -> [b]
-  , anyWithKey -- :: FoldableWithKey t => (Key t -> a -> Bool) -> t a -> Bool
-  , allWithKey -- :: FoldableWithKey t => (Key t -> a -> Bool) -> t a -> Bool
-  , findWithKey -- :: FoldableWithKey t => (Key t -> a -> Bool) -> t a -> Maybe a
-
-  -- * FoldableWithKey1
-  , FoldableWithKey1(..)
-  , traverseWithKey1_ -- :: (FoldableWithKey1 t, Apply f) => (Key t -> a -> f b) -> t a -> f ()
-  , forWithKey1_ -- :: (FoldableWithKey1 t, Apply f) => t a -> (Key t -> a -> f b) -> f ()
-  , foldMapWithKeyDefault1 -- :: (FoldableWithKey1, Monoid m) => (Key t -> a -> m) -> t a -> m
-
-  -- * TraversableWithKey
-  , TraversableWithKey(..)
-  , forWithKey -- :: (TraversableWithKey t, Applicative f) => t a -> (Key t -> a -> f b) -> f (t b)
-  , forWithKeyM -- :: (TraversableWithKey t, Monad m) => t a -> (Key t -> a -> m b) -> m (t b)
-  , mapAccumWithKeyL -- :: TraversableWithKey t => (Key t -> a -> b -> (a, c)) -> t a -> (a, t c)
-  , mapAccumWithKeyR -- :: TraversableWithKey t => (Key t -> a -> b -> (a, c)) -> t a -> (a, t c)
-  , 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(..)
-  , foldMapWithKey1Default -- :: (TraversableWithKey1 t, Semigroup m) => (Key t -> a -> m) -> t a -> m
-  ) where
-
-import Control.Applicative
-import Control.Comonad.Trans.Traced
-import Control.Monad.Free
-import Control.Comonad.Cofree
-import Control.Monad.Trans.Identity
-import Control.Monad.Trans.Reader
-import qualified Data.Array as Array
-import Data.Array (Array)
-import Data.Functor.Identity
-import Data.Functor.Bind
-import Data.Functor.Compose
-import Data.Functor.Product
-import Data.Functor.Coproduct
-import Data.Foldable
-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
-import Data.List.NonEmpty (NonEmpty(..))
-import qualified Data.List.NonEmpty as NonEmpty
-import Data.Maybe (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.Traversable
-import qualified Data.List as List
-import Prelude hiding (lookup, zip, zipWith)
-
--- TODO: half of the functions manipulating Cofree and Free buil the keys in the wrong order
-
-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
-
--- * Keyed
-class Functor f => Keyed f where
-  mapWithKey :: (Key f -> a -> b) -> f a -> f b
-
-instance Keyed f => Keyed (Free f) where
-  mapWithKey f (Pure a) = Pure (f Seq.empty a)
-  mapWithKey f (Free as) = Free (mapWithKey (mapWithKey . fmap f . flip (|>)) as)
-
-instance Keyed f => Keyed (Cofree f) where
-  mapWithKey f (a :< as) = f Seq.empty a :< mapWithKey (mapWithKey . fmap f . flip (|>)) as
-
-instance Keyed Tree where
-  mapWithKey f (Node a as) = Node (f Seq.empty a) (mapWithKey (mapWithKey . fmap f . flip (|>)) as)
-
-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
-
-  zip :: f a -> f b -> f (a, b)
-  zip = zipWith (,)
-
-  -- zip-like 'ap'
-  zap :: f (a -> b) -> f a -> f b
-  zap = zipWith id
-
-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)
-
-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
-
-  zapWithKey :: f (Key f -> a -> b) -> f a -> f b
-  zapWithKey = zipWithKey (\k f -> f k)
-
-instance ZipWithKey f => ZipWithKey (Cofree f) where
-  zipWithKey f (a :< as) (b :< bs) = f Seq.empty a b :< zipWithKey (zipWithKey . fmap f . flip (|>)) as bs
-
-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
-  
-infixl 4 <#$>
-
-(<#$>) :: Keyed f => (Key f -> a -> b) -> f a -> f b
-(<#$>) = mapWithKey
-{-# INLINE (<#$>) #-}
-
-keyed :: Keyed f => f a -> f (Key f, a)
-keyed = mapWithKey (,)
-{-# INLINE keyed #-}
-
--- * Indexable
-
-class Lookup f => Indexable f where
-  index :: f a -> Key f -> a
-
-instance Indexable f => Indexable (Cofree f) where
-  index (a :< as) key = case viewl key of 
-      EmptyL -> a
-      k Seq.:< ks -> index (index as k) ks
-
-instance Indexable Tree where
-  index (Node a as) key = case viewl key of 
-      EmptyL -> a
-      k Seq.:< ks -> index (index as k) ks
-
-(!) :: Indexable f => f a -> Key f -> a
-(!) = index
-
--- * Lookup
-
-class Lookup f where
-  lookup :: Key f -> f a -> Maybe a
-
-instance Lookup f => Lookup (Cofree f) where
-  lookup key (a :< as) = case viewl key of 
-    EmptyL -> Just a
-    k Seq.:< ks -> lookup k as >>= lookup ks
-
-instance Lookup Tree where
-  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 
-    | otherwise = Nothing
-  lookup key (Free as) = case viewl key of 
-    k Seq.:< ks -> lookup k as >>= lookup ks
-    _ -> Nothing
-  
-    
-lookupDefault :: Indexable f => Key f -> f a -> Maybe a
-lookupDefault k t = Just (index t k)
-
--- * Adjustable
-
-class Functor f => Adjustable f where
-  adjust :: (a -> a) -> Key f -> f a -> f a
-
-  replace :: Key f -> a -> f a -> f a
-  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 
-    | otherwise = as
-  adjust f key aas@(Free as) = case viewl key of
-    k Seq.:< ks -> Free $ adjust (adjust f ks) k as
-    _           -> aas
-
-instance Adjustable f => Adjustable (Cofree f) where
-  adjust f key (a :< as) = case viewl key of
-    k Seq.:< ks -> a   :< adjust (adjust f ks) k as
-    _           -> f a :< as
-
-instance Adjustable Tree where
-  adjust f key (Node a as) = case viewl key of
-    k Seq.:< ks -> a   `Node` adjust (adjust f ks) k as
-    _           -> f a `Node` as
-
--- * FoldableWithKey
-
-class Foldable t => FoldableWithKey t where
-  toKeyedList :: t a -> [(Key t, a)]
-  toKeyedList = foldrWithKey (\k v t -> (k,v):t) []
-
-  foldMapWithKey :: Monoid m => (Key t -> a -> m) -> t a -> m
-  foldMapWithKey f = foldrWithKey (\k v -> mappend (f k v)) mempty
-
-  foldrWithKey :: (Key t -> a -> b -> b) -> b -> t a -> b
-  foldrWithKey f z t = appEndo (foldMapWithKey (\k v -> Endo (f k v)) t) z
-
-  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
-
-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
-
-instance FoldableWithKey f => FoldableWithKey (Cofree f) where
-  foldMapWithKey f (a :< as) = f Seq.empty a `mappend` foldMapWithKey (foldMapWithKey . fmap f . flip (|>)) as
-
-instance FoldableWithKey Tree where
-  foldMapWithKey f (Node a as) = f Seq.empty a `mappend` foldMapWithKey (foldMapWithKey . fmap f . flip (|>)) as
-
-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
-{-# INLINE foldrWithKey' #-}
-
-foldlWithKey' :: FoldableWithKey t => (b -> Key t -> a -> b) -> b -> t a -> b
-foldlWithKey' f z0 xs = foldrWithKey f' id xs z0
-  where f' key x k z = k $! f z key x
-{-# INLINE foldlWithKey' #-}
-
-foldrWithKeyM :: (FoldableWithKey t, Monad m) => (Key t -> a -> b -> m b) -> b -> t a -> m b
-foldrWithKeyM f z0 xs = foldlWithKey f' return xs z0
-  where f' k key x z = f key x z >>= k
-{-# INLINE foldrWithKeyM #-}
-
-foldlWithKeyM :: (FoldableWithKey t, Monad m) => (b -> Key t -> a -> m b) -> b -> t a -> m b
-foldlWithKeyM f z0 xs = foldrWithKey f' return xs z0
-  where f' key x k z = f z key x >>= k
-{-# INLINE foldlWithKeyM #-}
-
-traverseWithKey_ :: (FoldableWithKey t, Applicative f) => (Key t -> a -> f b) -> t a -> f ()
-traverseWithKey_ f = foldrWithKey (fmap (*>) . f) (pure ())
-{-# INLINE traverseWithKey_ #-}
-
-forWithKey_ :: (FoldableWithKey t, Applicative f) => t a -> (Key t -> a -> f b) -> f ()
-forWithKey_ = flip traverseWithKey_
-{-# INLINE forWithKey_ #-}
-
-mapWithKeyM_ :: (FoldableWithKey t, Monad m) => (Key t -> a -> m b) -> t a -> m ()
-mapWithKeyM_ f = foldrWithKey (fmap (>>) . f) (return ())
-{-# INLINE mapWithKeyM_ #-}
-
-forWithKeyM_ :: (FoldableWithKey t, Monad m) => t a -> (Key t -> a -> m b) -> m ()
-forWithKeyM_ = flip mapWithKeyM_
-{-# INLINE forWithKeyM_ #-}
-
-concatMapWithKey :: FoldableWithKey t => (Key t -> a -> [b]) -> t a -> [b]
-concatMapWithKey = foldMapWithKey
-{-# INLINE concatMapWithKey #-}
-
-anyWithKey :: FoldableWithKey t => (Key t -> a -> Bool) -> t a -> Bool
-anyWithKey p = getAny . foldMapWithKey (fmap Any . p)
-{-# INLINE anyWithKey #-}
-
-allWithKey :: FoldableWithKey t => (Key t -> a -> Bool) -> t a -> Bool
-allWithKey p = getAll . foldMapWithKey (fmap All . p)
-{-# INLINE allWithKey #-}
-
-findWithKey :: FoldableWithKey t => (Key t -> a -> Bool) -> t a -> Maybe a
-findWithKey p = Monoid.getFirst . foldMapWithKey (\k x -> Monoid.First (if p k x then Just x else Nothing) )
-{-# INLINE findWithKey #-}
-
--- * FoldableWithKey1
-
-class (Foldable1 t, FoldableWithKey t) => FoldableWithKey1 t where
-  foldMapWithKey1 :: Semigroup m => (Key t -> a -> m) -> t a -> m
-
--- TODO
---instance Foldable f => Foldable1 (Cofree f) where
---  foldMap1 f (a :< as) = appEndo (getDual . foldMap (Dual . diff . foldMap1 f)) (f a)
-
-instance FoldableWithKey1 f => FoldableWithKey1 (Cofree f) where
-  foldMapWithKey1 f (a :< as) = f Seq.empty a <> foldMapWithKey1 (foldMapWithKey1 . fmap f . flip (|>)) as
-
-instance FoldableWithKey1 Tree where
-  foldMapWithKey1 f (Node a []) = f Seq.empty a
-  foldMapWithKey1 f (Node a (x:xs)) = f Seq.empty a <> foldMapWithKey1 (foldMapWithKey1 . fmap f . flip (|>)) (x:|xs)
-
-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
-  
-newtype Act f a = Act { getAct :: f a }
-
-instance Apply f => Semigroup (Act f a) where
-  Act a <> Act b = Act (a .> b)
-
-instance Functor f => Functor (Act f) where
-  fmap f (Act a) = Act (f <$> a)
-  b <$ Act a = Act (b <$ a)
-
-traverseWithKey1_ :: (FoldableWithKey1 t, Apply f) => (Key t -> a -> f b) -> t a -> f ()
-traverseWithKey1_ f = (<$) () . getAct . foldMapWithKey1 (fmap Act . f)
-{-# INLINE traverseWithKey1_ #-}
-
-forWithKey1_ :: (FoldableWithKey1 t, Apply f) => t a -> (Key t -> a -> f b) -> f ()
-forWithKey1_ = flip traverseWithKey1_
-{-# INLINE forWithKey1_ #-}
-
-foldMapWithKeyDefault1 :: (FoldableWithKey1 t, Monoid m) => (Key t -> a -> m) -> t a -> m
-foldMapWithKeyDefault1 f = unwrapMonoid . foldMapWithKey (fmap WrapMonoid . f)
-{-# INLINE foldMapWithKeyDefault1 #-}
-
--- * TraversableWithKey
-
-class (Keyed t, FoldableWithKey t, Traversable t) => TraversableWithKey t where
-  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) 
-
-instance TraversableWithKey f => TraversableWithKey (Cofree f) where
-  traverseWithKey f (a :< as) = (:<) <$> f Seq.empty a <*> traverseWithKey (traverseWithKey . fmap f . flip (|>)) as
-
-instance TraversableWithKey Tree where
-  traverseWithKey f (Node a as) = Node <$> f Seq.empty a <*> traverseWithKey (traverseWithKey . fmap f . flip (|>)) as
-
-instance TraversableWithKey f => TraversableWithKey (Free f) where
-  traverseWithKey f (Pure a) = Pure <$> f Seq.empty a
-  traverseWithKey f (Free as) = Free <$> traverseWithKey (traverseWithKey . fmap f . flip (|>)) as
-
-forWithKey :: (TraversableWithKey t, Applicative f) => t a -> (Key t -> a -> f b) -> f (t b)
-forWithKey = flip traverseWithKey
-{-# INLINE forWithKey #-}
-
-forWithKeyM :: (TraversableWithKey t, Monad m) => t a -> (Key t -> a -> m b) -> m (t b)
-forWithKeyM = flip mapWithKeyM
-{-# INLINE forWithKeyM #-}
-
--- left-to-right state transformer
-newtype StateL s a = StateL { runStateL :: s -> (s, a) }
-
-instance Functor (StateL s) where
-  fmap f (StateL k) = StateL $ \ s ->
-    let (s', v) = k s in (s', f v)
-
-instance Applicative (StateL s) where
-  pure x = StateL (\ s -> (s, x))
-  StateL kf <*> StateL kv = StateL $ \ s ->
-    let (s', f) = kf s
-        (s'', v) = kv s'
-    in  (s'', f v)
-
--- |The 'mapAccumWithKeyL' function behaves like a combination of 'mapWithKey'
--- and 'foldlWithKey'; it applies a function to each element of a structure,
--- passing an accumulating parameter from left to right, and returning
--- a final value of this accumulator together with the new structure.
-mapAccumWithKeyL :: TraversableWithKey t => (Key t -> a -> b -> (a, c)) -> a -> t b -> (a, t c)
-mapAccumWithKeyL f s t = runStateL (traverseWithKey (\k b -> StateL (\a -> f k a b)) t) s
-{-# INLINE mapAccumWithKeyL #-}
-
--- right-to-left state transformer
-newtype StateR s a = StateR { runStateR :: s -> (s, a) }
-
-instance Functor (StateR s) where
-  fmap f (StateR k) = StateR $ \ s ->
-    let (s', v) = k s in (s', f v)
-
-instance Applicative (StateR s) where
-  pure x = StateR (\ s -> (s, x))
-  StateR kf <*> StateR kv = StateR $ \ s ->
-    let (s', v) = kv s
-        (s'', f) = kf s'
-    in (s'', f v)
-
--- |The 'mapAccumWithKeyR' function behaves like a combination of 'mapWithKey'
--- and 'foldrWithKey'; it applies a function to each element of a structure,
--- passing an accumulating parameter from right to left, and returning
--- a final value of this accumulator together with the new structure.
-mapAccumWithKeyR :: TraversableWithKey t => (Key t -> a -> b -> (a, c)) -> a -> t b -> (a, t c)
-mapAccumWithKeyR f s t = runStateR (traverseWithKey (\k b -> StateR (\a -> f k a b)) t) s
-{-# INLINE mapAccumWithKeyR #-}
-
-mapWithKeyDefault :: TraversableWithKey t => (Key t -> a -> b) -> t a -> t b
-mapWithKeyDefault f = runIdentity . traverseWithKey (fmap Identity . f)
-{-# INLINE mapWithKeyDefault #-}
-
--- | This function may be used as a value for `Data.Foldable.foldMapWithKey`
--- in a `FoldableWithKey` instance.
-foldMapWithKeyDefault :: (TraversableWithKey t, Monoid m) => (Key t -> a -> m) -> t a -> m
-foldMapWithKeyDefault f = getConst . traverseWithKey (fmap Const . f)
-{-# INLINE foldMapWithKeyDefault #-}
-
--- * TraverableWithKey1
-class (Traversable1 t, FoldableWithKey1 t, TraversableWithKey t) => TraversableWithKey1 t where
-  traverseWithKey1 :: Apply f => (Key t -> a -> f b) -> t a -> f (t b)
-
--- 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
-
-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
-
-foldMapWithKey1Default :: (TraversableWithKey1 t, Semigroup m) => (Key t -> a -> m) -> t a -> m
-foldMapWithKey1Default f = getConst . traverseWithKey1 (\k -> Const . f k)
-{-# INLINE foldMapWithKey1Default #-}
-
--- * Instances
-
-type instance Key Identity = ()
-
-instance Indexable Identity where
-  index (Identity a) _ = a
-
-instance Lookup Identity where
-  lookup _ (Identity a) = Just a
-
-instance Adjustable Identity where
-  adjust f _ (Identity a) = Identity (f a)
-  replace _ b _ = Identity b
-
-instance Zip Identity where
-  zipWith f (Identity a) (Identity b) = Identity (f a b)
-
-instance ZipWithKey Identity where
-  zipWithKey f (Identity a) (Identity b) = Identity (f () a b)
-
-instance Keyed Identity where
-  mapWithKey f = Identity . f () . runIdentity
-
-instance FoldableWithKey Identity where
-  foldrWithKey f z (Identity a) = f () a z
-
-instance FoldableWithKey1 Identity where
-  foldMapWithKey1 f (Identity a) = f () a
-
-instance TraversableWithKey Identity where
-  traverseWithKey f (Identity a) = Identity <$> f () a
-
-instance TraversableWithKey1 Identity where
-  traverseWithKey1 f (Identity a) = Identity <$> f () a
-
-type instance Key (IdentityT m) = Key m
-
-instance Indexable m => Indexable (IdentityT m) where
-  index (IdentityT m) i = index m i
-
-instance Lookup m => Lookup (IdentityT m) where
-  lookup i (IdentityT m) = lookup i m
-
-instance Zip m => Zip (IdentityT m) where
-  zipWith f (IdentityT m) (IdentityT n) = IdentityT (zipWith f m n)
-
-instance ZipWithKey m => ZipWithKey (IdentityT m) where
-  zipWithKey f (IdentityT m) (IdentityT n) = IdentityT (zipWithKey f m n)
-
-instance Keyed m => Keyed (IdentityT m) where
-  mapWithKey f = IdentityT . mapWithKey f . runIdentityT 
-
-instance FoldableWithKey m => FoldableWithKey (IdentityT m) where
-  foldrWithKey f z (IdentityT m) = foldrWithKey f z m
-
-instance FoldableWithKey1 m => FoldableWithKey1 (IdentityT m) where
-  foldMapWithKey1 f (IdentityT m) = foldMapWithKey1 f m
-
-instance TraversableWithKey m => TraversableWithKey (IdentityT m) where
-  traverseWithKey f (IdentityT a) = IdentityT <$> traverseWithKey f a
-
-instance TraversableWithKey1 m => TraversableWithKey1 (IdentityT m) where
-  traverseWithKey1 f (IdentityT a) = IdentityT <$> traverseWithKey1 f a
-
-type instance Key ((->)a) = a
-
-instance Keyed ((->)a) where
-  mapWithKey = (<*>)
-
-instance Zip ((->)a) where
-  zipWith f g h a = f (g a) (h a)
-
-instance ZipWithKey ((->)a) where
-  zipWithKey f g h a = f a (g a) (h a)
-
-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 (m a) (n a)
-
-instance ZipWithKey m => ZipWithKey (ReaderT e m) where
-  zipWithKey f (ReaderT m) (ReaderT n) = ReaderT $ \a -> 
-    zipWithKey (f . (,) a) (m a) (n a)
-
-instance Keyed m => Keyed (ReaderT e m) where
-  mapWithKey f (ReaderT m) = ReaderT $ \k -> mapWithKey (f . (,) k) (m k)
-
-instance Indexable m => Indexable (ReaderT e m) where
-  index (ReaderT f) (e,k) = index (f e) k
-
-instance Lookup m => Lookup (ReaderT e m) where
-  lookup (e,k) (ReaderT f) = lookup k (f e)
-
-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 (\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 (\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 
-
-instance Indexable w => Indexable (TracedT s w) where
-  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
-  zipWith = IntMap.intersectionWith
-
-instance ZipWithKey IntMap where
-  zipWithKey = IntMap.intersectionWithKey
-
-instance Keyed IntMap where
-  mapWithKey = IntMap.mapWithKey
-
-instance FoldableWithKey IntMap where
-  foldrWithKey = IntMap.foldWithKey
-
-instance TraversableWithKey IntMap where
-  traverseWithKey f = fmap IntMap.fromDistinctAscList . traverse (\(k, v) -> (,) k <$> f k v) . IntMap.toAscList
-
-instance Indexable IntMap where
-  index = (IntMap.!)
-
-instance Lookup IntMap where
-  lookup = IntMap.lookup
-
-instance Adjustable IntMap where
-  adjust = IntMap.adjust
-
-type instance Key (Compose f g) = (Key f, Key g)
-
-instance (Zip f, Zip g) => Zip (Compose f g) where
-  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 (zipWithKey . fmap f . (,)) a b
-
-instance (Keyed f, Keyed g) => Keyed (Compose f g) where
-  mapWithKey f = Compose . mapWithKey (\k -> mapWithKey (f . (,) k)) . getCompose
-
-instance (Indexable f, Indexable g) => Indexable (Compose f g) where
-  index (Compose fg) (i,j) = index (index fg i) j
-
-instance (Lookup f, Lookup g) => Lookup (Compose f g) where
-  lookup (i,j) (Compose fg) = lookup i fg >>= lookup j
-
-instance (FoldableWithKey f, FoldableWithKey m) => FoldableWithKey (Compose f m) where
-  foldMapWithKey f = foldMapWithKey (\k -> foldMapWithKey (f . (,) k)) . getCompose
-
-instance (FoldableWithKey1 f, FoldableWithKey1 m) => FoldableWithKey1 (Compose f m) where
-  foldMapWithKey1 f = foldMapWithKey1 (\k -> foldMapWithKey1 (f . (,) k)) . getCompose
-
-instance (TraversableWithKey f, TraversableWithKey m) => TraversableWithKey (Compose f m) where
-  traverseWithKey f = fmap Compose . traverseWithKey (\k -> traverseWithKey (f . (,) k)) . getCompose
-
-instance (TraversableWithKey1 f, TraversableWithKey1 m) => TraversableWithKey1 (Compose f m) where
-  traverseWithKey1 f = fmap Compose . traverseWithKey1 (\k -> traverseWithKey1 (f . (,) k)) . getCompose
-
-type instance Key [] = Int
-
-instance Zip [] where
-  zip = List.zip
-  zipWith = List.zipWith
-
-instance ZipWithKey [] where
-  zipWithKey f = go 0 where
-    go _ [] _ = []
-    go _ _ [] = []
-    go n (x:xs) (y:ys) = n' `seq` f n x y : go n' xs ys
-      where n' = n + 1 
-
-instance Keyed [] where
-  mapWithKey f xs0 = go xs0 0 where
-    go [] _ = []
-    go (x:xs) n = f n x : (go xs $! (n + 1))
-
-instance FoldableWithKey [] where
-  foldrWithKey f z0 xs0 = go z0 xs0 0 where
-    go z [] _ = z
-    go z (x:xs) n = f n x (go z xs $! (n + 1))
-
-instance TraversableWithKey [] where
-  traverseWithKey f xs0 = go xs0 0 where
-    go [] _ = pure []
-    go (x:xs) n = (:) <$> f n x <*> (go xs $! (n + 1))
-
-instance Indexable [] where
-  index = (!!)
-
-instance Lookup [] where
-  lookup = fmap listToMaybe . drop
-
-instance Adjustable [] where
-  adjust f 0 (x:xs) = f x : xs
-  adjust _ _ [] = []
-  adjust f n (x:xs) = n' `seq` x : adjust f n' xs where n' = n - 1
-
-
-
-instance Zip NonEmpty where
-  zipWith = NonEmpty.zipWith
-
-instance ZipWithKey NonEmpty where
-  zipWithKey f (a:|as) (b:|bs) = f 0 a b :| zipWithKey (f . (+1)) as bs
-
-instance Keyed NonEmpty where
-  mapWithKey f (a:|as) = f 0 a :| mapWithKey (f . (+1)) as
-
-instance FoldableWithKey NonEmpty where
-  foldrWithKey f z (x:|xs) = f 0 x (foldrWithKey (f . (+1)) z xs)
-
-instance TraversableWithKey NonEmpty where
-  traverseWithKey f (x :| xs) = (:|) <$> f 0 x <*> traverseWithKey (f . (+1)) xs
-
-instance Indexable NonEmpty where
-  index (x:|_) 0 = x
-  index (_:|xs) i = xs !! (i - 1)
-
-instance Lookup NonEmpty where
-  lookup 0 (x:|_) = Just x
-  lookup n (_:|xs) = lookup (n - 1) xs
-
-instance Adjustable NonEmpty where
-  adjust f 0 (x:|xs) = f x :| xs
-  adjust f n (x:|xs) = x :| adjust f (n - 1) xs
-
-instance FoldableWithKey1 NonEmpty where
-  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
-  traverseWithKey1 f (x:|[]) = (:|[]) <$> f 0 x
-  traverseWithKey1 f (x:|(y:ys)) = (\w (z:|zs) -> w :| (z:zs)) <$> f 0 x <.> traverseWithKey1 (f . (+1)) (y :| ys)
-
-type instance Key Seq = Int
-
-instance Indexable Seq where
-  index = Seq.index
-
-instance Lookup Seq where
-  lookup i s = case viewl (Seq.drop i s) of
-    EmptyL -> Nothing
-    a Seq.:< _ -> Just a
-
-instance Zip Seq where
-  zip = Seq.zip
-  zipWith = Seq.zipWith
-
-instance ZipWithKey Seq where
-  zipWithKey f a b = Seq.zipWith id (Seq.mapWithIndex f a) b
-
-instance Adjustable Seq where
-  adjust = Seq.adjust
-
-instance Keyed Seq where
-  mapWithKey = Seq.mapWithIndex
-
-instance FoldableWithKey Seq where
-  foldrWithKey = Seq.foldrWithIndex
-
-instance TraversableWithKey Seq where
-  traverseWithKey f = fmap Seq.fromList . traverseWithKey f . toList
-
-type instance Key (Map k) = k
-
-instance Ord k => Zip (Map k) where
-  zipWith = Map.intersectionWith
-
-instance Ord k => ZipWithKey (Map k) where
-  zipWithKey = Map.intersectionWithKey
-
-instance Keyed (Map k) where
-  mapWithKey = Map.mapWithKey
-
-instance Ord k => Indexable (Map k) where
-  index = (Map.!)
-
-instance Ord k => Lookup (Map k) where
-  lookup = Map.lookup
-
-instance FoldableWithKey (Map k) where
-  foldrWithKey = Map.foldrWithKey
-
-instance TraversableWithKey (Map k) where
-  traverseWithKey f = fmap Map.fromDistinctAscList . traverse (\(k, v) -> (,) k <$> f k v) . Map.toAscList
-
-instance Ord k => Adjustable (Map k) where
-  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.!)
-
-instance Ix i => Lookup (Array i) where
-  lookup i arr
-    | inRange (Array.bounds arr) i = Just (arr Array.! i)
-    | otherwise = Nothing
-
-instance Ix i => FoldableWithKey (Array i) where
-  foldrWithKey f z = Prelude.foldr (uncurry f) z . Array.assocs
-
-instance Ix i => TraversableWithKey (Array i) where
-  traverseWithKey f arr = Array.listArray (Array.bounds arr) <$> traverse (uncurry f) (Array.assocs arr)
-
-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
-
-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 (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))
-
-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 _ b) (Right j) = index b j
-
-instance (Lookup f, Lookup g) => Lookup (Product f g) where
-  lookup (Left i) (Pair a _) = lookup i a
-  lookup (Right j) (Pair _ b) = lookup j b
-
-instance (Zip f, Zip g) => Zip (Product f g) where
-  zipWith f (Pair a b) (Pair c d) = Pair (zipWith f a c) (zipWith f b d)
-
-instance (ZipWithKey f, ZipWithKey g) => ZipWithKey (Product f g) where
-  zipWithKey f (Pair a b) (Pair c d) = Pair (zipWithKey (f . Left) a c) (zipWithKey (f . Right) b d)
-
--- interleave?
-instance (FoldableWithKey f, FoldableWithKey g) => FoldableWithKey (Product f g) where
-  foldMapWithKey f (Pair a b) = foldMapWithKey (f . Left) a `mappend` foldMapWithKey (f . Right) b
-
-instance (FoldableWithKey1 f, FoldableWithKey1 g) => FoldableWithKey1 (Product f g) where
-  foldMapWithKey1 f (Pair a b) = foldMapWithKey1 (f . Left) a <> foldMapWithKey1 (f . Right) b
-
-instance (TraversableWithKey f, TraversableWithKey g) => TraversableWithKey (Product f g) where
-  traverseWithKey f (Pair a b) = Pair <$> traverseWithKey (f . Left) a <*> traverseWithKey (f . Right) b
-
-instance (TraversableWithKey1 f, TraversableWithKey1 g) => TraversableWithKey1 (Product f g) where
-  traverseWithKey1 f (Pair a b) = Pair <$> traverseWithKey1 (f . Left) a <.> traverseWithKey1 (f . Right) b
-
-instance (Adjustable f, Adjustable g) => Adjustable (Product f g) where
-  adjust f (Left i) (Pair a b)  = Pair (adjust f i a) b
-  adjust f (Right j) (Pair a b) = Pair a (adjust f j b)
-  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)
-
diff --git a/keys.cabal b/keys.cabal
--- a/keys.cabal
+++ b/keys.cabal
@@ -1,6 +1,6 @@
 name:          keys
 category:      Data Structures, Containers
-version:       3.0.1.1
+version:       3.0.2
 license:       BSD3
 cabal-version: >= 1.6
 license-file:  LICENSE
@@ -25,14 +25,14 @@
     base                 >= 4       && < 5,
     containers           >= 0.3     && < 0.6,
     transformers         >= 0.2     && < 0.4,
-    semigroups           >= 0.8.3.1 && < 0.9,
-    semigroupoids        >= 3.0     && < 3.1,
-    comonad-transformers >= 3.0     && < 3.1,
-    comonads-fd          >= 3.0     && < 3.1,
-    free                 >= 3.0     && < 3.4
+    semigroups           >= 0.8.3.1,
+    semigroupoids        >= 3.0,
+    comonad-transformers >= 3.0,
+    comonads-fd          >= 3.0,
+    free                 >= 3.0
 
   exposed-modules:
     Data.Key
 
   ghc-options: -Wall
-
+  hs-source-dirs: src
diff --git a/src/Data/Key.hs b/src/Data/Key.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Key.hs
@@ -0,0 +1,828 @@
+{-# LANGUAGE TypeFamilies #-}
+module Data.Key (
+  -- * Keys
+    Key
+
+  -- * Keyed functors
+  , Keyed(..)
+  , (<#$>) -- :: Keyed f => (Key f -> a -> b) -> f a -> f b
+  , keyed -- :: Keyed f => f a -> f (Key f, a)
+
+  -- * Zippable functors
+  , Zip(..)
+
+  -- * Zipping keyed functors 
+  , ZipWithKey(..)
+
+  -- * Indexable functors
+  , Indexable(..)
+  , (!)
+
+  -- * Safe Lookup
+  , Lookup(..)
+  , lookupDefault
+
+  -- * Adjustable
+  , Adjustable(..)
+
+  -- * FoldableWithKey
+  , FoldableWithKey(..)
+  , foldrWithKey' -- :: FoldableWithKey t => (Key t -> a -> b -> b) -> b -> t a -> b
+  , foldlWithKey' -- :: FoldableWithKey t => (b -> Key t -> a -> b) -> b -> t a -> b
+  , foldrWithKeyM -- :: (FoldableWithKey t, Monad m) => (Key t -> a -> b -> m b) -> b -> t a -> m b
+  , foldlWithKeyM -- :: (FoldableWithKey t, Monad m) => (b -> Key t -> a -> m b) -> b -> t a -> m b
+  , traverseWithKey_ -- :: (FoldableWithKey t, Applicative f) => (Key t -> a -> f b) -> t a -> f ()
+  , forWithKey_ -- :: (FoldableWithKey t, Applicative f) => t a -> (Key t -> a -> f b) -> f ()
+  , mapWithKeyM_ -- :: (FoldableWithKey t, Monad m) => (Key t -> a -> m b) -> t a -> m ()
+  , forWithKeyM_ -- :: (FoldableWithKey t, Monad m) => t a -> (Key t -> a -> m b) -> m ()
+  , concatMapWithKey -- :: FoldableWithKey t => (Key t -> a -> [b]) -> t a -> [b]
+  , anyWithKey -- :: FoldableWithKey t => (Key t -> a -> Bool) -> t a -> Bool
+  , allWithKey -- :: FoldableWithKey t => (Key t -> a -> Bool) -> t a -> Bool
+  , findWithKey -- :: FoldableWithKey t => (Key t -> a -> Bool) -> t a -> Maybe a
+
+  -- * FoldableWithKey1
+  , FoldableWithKey1(..)
+  , traverseWithKey1_ -- :: (FoldableWithKey1 t, Apply f) => (Key t -> a -> f b) -> t a -> f ()
+  , forWithKey1_ -- :: (FoldableWithKey1 t, Apply f) => t a -> (Key t -> a -> f b) -> f ()
+  , foldMapWithKeyDefault1 -- :: (FoldableWithKey1, Monoid m) => (Key t -> a -> m) -> t a -> m
+
+  -- * TraversableWithKey
+  , TraversableWithKey(..)
+  , forWithKey -- :: (TraversableWithKey t, Applicative f) => t a -> (Key t -> a -> f b) -> f (t b)
+  , forWithKeyM -- :: (TraversableWithKey t, Monad m) => t a -> (Key t -> a -> m b) -> m (t b)
+  , mapAccumWithKeyL -- :: TraversableWithKey t => (Key t -> a -> b -> (a, c)) -> t a -> (a, t c)
+  , mapAccumWithKeyR -- :: TraversableWithKey t => (Key t -> a -> b -> (a, c)) -> t a -> (a, t c)
+  , 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(..)
+  , foldMapWithKey1Default -- :: (TraversableWithKey1 t, Semigroup m) => (Key t -> a -> m) -> t a -> m
+  ) where
+
+import Control.Applicative
+import Control.Comonad.Trans.Traced
+import Control.Monad.Free
+import Control.Comonad.Cofree
+import Control.Monad.Trans.Identity
+import Control.Monad.Trans.Reader
+import qualified Data.Array as Array
+import Data.Array (Array)
+import Data.Functor.Identity
+import Data.Functor.Bind
+import Data.Functor.Compose
+import Data.Functor.Product
+import Data.Functor.Coproduct
+import Data.Foldable
+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
+import Data.List.NonEmpty (NonEmpty(..))
+import qualified Data.List.NonEmpty as NonEmpty
+import Data.Maybe (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.Traversable
+import qualified Data.List as List
+import Prelude hiding (lookup, zip, zipWith)
+
+-- TODO: half of the functions manipulating Cofree and Free buil the keys in the wrong order
+
+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
+
+-- * Keyed
+class Functor f => Keyed f where
+  mapWithKey :: (Key f -> a -> b) -> f a -> f b
+
+instance Keyed f => Keyed (Free f) where
+  mapWithKey f (Pure a) = Pure (f Seq.empty a)
+  mapWithKey f (Free as) = Free (mapWithKey (mapWithKey . fmap f . flip (|>)) as)
+
+instance Keyed f => Keyed (Cofree f) where
+  mapWithKey f (a :< as) = f Seq.empty a :< mapWithKey (mapWithKey . fmap f . flip (|>)) as
+
+instance Keyed Tree where
+  mapWithKey f (Node a as) = Node (f Seq.empty a) (mapWithKey (mapWithKey . fmap f . flip (|>)) as)
+
+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
+
+  zip :: f a -> f b -> f (a, b)
+  zip = zipWith (,)
+
+  -- zip-like 'ap'
+  zap :: f (a -> b) -> f a -> f b
+  zap = zipWith id
+
+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)
+
+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
+
+  zapWithKey :: f (Key f -> a -> b) -> f a -> f b
+  zapWithKey = zipWithKey (\k f -> f k)
+
+instance ZipWithKey f => ZipWithKey (Cofree f) where
+  zipWithKey f (a :< as) (b :< bs) = f Seq.empty a b :< zipWithKey (zipWithKey . fmap f . flip (|>)) as bs
+
+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
+  
+infixl 4 <#$>
+
+(<#$>) :: Keyed f => (Key f -> a -> b) -> f a -> f b
+(<#$>) = mapWithKey
+{-# INLINE (<#$>) #-}
+
+keyed :: Keyed f => f a -> f (Key f, a)
+keyed = mapWithKey (,)
+{-# INLINE keyed #-}
+
+-- * Indexable
+
+class Lookup f => Indexable f where
+  index :: f a -> Key f -> a
+
+instance Indexable f => Indexable (Cofree f) where
+  index (a :< as) key = case viewl key of 
+      EmptyL -> a
+      k Seq.:< ks -> index (index as k) ks
+
+instance Indexable Tree where
+  index (Node a as) key = case viewl key of 
+      EmptyL -> a
+      k Seq.:< ks -> index (index as k) ks
+
+(!) :: Indexable f => f a -> Key f -> a
+(!) = index
+
+-- * Lookup
+
+class Lookup f where
+  lookup :: Key f -> f a -> Maybe a
+
+instance Lookup f => Lookup (Cofree f) where
+  lookup key (a :< as) = case viewl key of 
+    EmptyL -> Just a
+    k Seq.:< ks -> lookup k as >>= lookup ks
+
+instance Lookup Tree where
+  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 
+    | otherwise = Nothing
+  lookup key (Free as) = case viewl key of 
+    k Seq.:< ks -> lookup k as >>= lookup ks
+    _ -> Nothing
+  
+    
+lookupDefault :: Indexable f => Key f -> f a -> Maybe a
+lookupDefault k t = Just (index t k)
+
+-- * Adjustable
+
+class Functor f => Adjustable f where
+  adjust :: (a -> a) -> Key f -> f a -> f a
+
+  replace :: Key f -> a -> f a -> f a
+  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 
+    | otherwise = as
+  adjust f key aas@(Free as) = case viewl key of
+    k Seq.:< ks -> Free $ adjust (adjust f ks) k as
+    _           -> aas
+
+instance Adjustable f => Adjustable (Cofree f) where
+  adjust f key (a :< as) = case viewl key of
+    k Seq.:< ks -> a   :< adjust (adjust f ks) k as
+    _           -> f a :< as
+
+instance Adjustable Tree where
+  adjust f key (Node a as) = case viewl key of
+    k Seq.:< ks -> a   `Node` adjust (adjust f ks) k as
+    _           -> f a `Node` as
+
+-- * FoldableWithKey
+
+class Foldable t => FoldableWithKey t where
+  toKeyedList :: t a -> [(Key t, a)]
+  toKeyedList = foldrWithKey (\k v t -> (k,v):t) []
+
+  foldMapWithKey :: Monoid m => (Key t -> a -> m) -> t a -> m
+  foldMapWithKey f = foldrWithKey (\k v -> mappend (f k v)) mempty
+
+  foldrWithKey :: (Key t -> a -> b -> b) -> b -> t a -> b
+  foldrWithKey f z t = appEndo (foldMapWithKey (\k v -> Endo (f k v)) t) z
+
+  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
+
+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
+
+instance FoldableWithKey f => FoldableWithKey (Cofree f) where
+  foldMapWithKey f (a :< as) = f Seq.empty a `mappend` foldMapWithKey (foldMapWithKey . fmap f . flip (|>)) as
+
+instance FoldableWithKey Tree where
+  foldMapWithKey f (Node a as) = f Seq.empty a `mappend` foldMapWithKey (foldMapWithKey . fmap f . flip (|>)) as
+
+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
+{-# INLINE foldrWithKey' #-}
+
+foldlWithKey' :: FoldableWithKey t => (b -> Key t -> a -> b) -> b -> t a -> b
+foldlWithKey' f z0 xs = foldrWithKey f' id xs z0
+  where f' key x k z = k $! f z key x
+{-# INLINE foldlWithKey' #-}
+
+foldrWithKeyM :: (FoldableWithKey t, Monad m) => (Key t -> a -> b -> m b) -> b -> t a -> m b
+foldrWithKeyM f z0 xs = foldlWithKey f' return xs z0
+  where f' k key x z = f key x z >>= k
+{-# INLINE foldrWithKeyM #-}
+
+foldlWithKeyM :: (FoldableWithKey t, Monad m) => (b -> Key t -> a -> m b) -> b -> t a -> m b
+foldlWithKeyM f z0 xs = foldrWithKey f' return xs z0
+  where f' key x k z = f z key x >>= k
+{-# INLINE foldlWithKeyM #-}
+
+traverseWithKey_ :: (FoldableWithKey t, Applicative f) => (Key t -> a -> f b) -> t a -> f ()
+traverseWithKey_ f = foldrWithKey (fmap (*>) . f) (pure ())
+{-# INLINE traverseWithKey_ #-}
+
+forWithKey_ :: (FoldableWithKey t, Applicative f) => t a -> (Key t -> a -> f b) -> f ()
+forWithKey_ = flip traverseWithKey_
+{-# INLINE forWithKey_ #-}
+
+mapWithKeyM_ :: (FoldableWithKey t, Monad m) => (Key t -> a -> m b) -> t a -> m ()
+mapWithKeyM_ f = foldrWithKey (fmap (>>) . f) (return ())
+{-# INLINE mapWithKeyM_ #-}
+
+forWithKeyM_ :: (FoldableWithKey t, Monad m) => t a -> (Key t -> a -> m b) -> m ()
+forWithKeyM_ = flip mapWithKeyM_
+{-# INLINE forWithKeyM_ #-}
+
+concatMapWithKey :: FoldableWithKey t => (Key t -> a -> [b]) -> t a -> [b]
+concatMapWithKey = foldMapWithKey
+{-# INLINE concatMapWithKey #-}
+
+anyWithKey :: FoldableWithKey t => (Key t -> a -> Bool) -> t a -> Bool
+anyWithKey p = getAny . foldMapWithKey (fmap Any . p)
+{-# INLINE anyWithKey #-}
+
+allWithKey :: FoldableWithKey t => (Key t -> a -> Bool) -> t a -> Bool
+allWithKey p = getAll . foldMapWithKey (fmap All . p)
+{-# INLINE allWithKey #-}
+
+findWithKey :: FoldableWithKey t => (Key t -> a -> Bool) -> t a -> Maybe a
+findWithKey p = Monoid.getFirst . foldMapWithKey (\k x -> Monoid.First (if p k x then Just x else Nothing) )
+{-# INLINE findWithKey #-}
+
+-- * FoldableWithKey1
+
+class (Foldable1 t, FoldableWithKey t) => FoldableWithKey1 t where
+  foldMapWithKey1 :: Semigroup m => (Key t -> a -> m) -> t a -> m
+
+-- TODO
+--instance Foldable f => Foldable1 (Cofree f) where
+--  foldMap1 f (a :< as) = appEndo (getDual . foldMap (Dual . diff . foldMap1 f)) (f a)
+
+instance FoldableWithKey1 f => FoldableWithKey1 (Cofree f) where
+  foldMapWithKey1 f (a :< as) = f Seq.empty a <> foldMapWithKey1 (foldMapWithKey1 . fmap f . flip (|>)) as
+
+instance FoldableWithKey1 Tree where
+  foldMapWithKey1 f (Node a []) = f Seq.empty a
+  foldMapWithKey1 f (Node a (x:xs)) = f Seq.empty a <> foldMapWithKey1 (foldMapWithKey1 . fmap f . flip (|>)) (x:|xs)
+
+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
+  
+newtype Act f a = Act { getAct :: f a }
+
+instance Apply f => Semigroup (Act f a) where
+  Act a <> Act b = Act (a .> b)
+
+instance Functor f => Functor (Act f) where
+  fmap f (Act a) = Act (f <$> a)
+  b <$ Act a = Act (b <$ a)
+
+traverseWithKey1_ :: (FoldableWithKey1 t, Apply f) => (Key t -> a -> f b) -> t a -> f ()
+traverseWithKey1_ f = (<$) () . getAct . foldMapWithKey1 (fmap Act . f)
+{-# INLINE traverseWithKey1_ #-}
+
+forWithKey1_ :: (FoldableWithKey1 t, Apply f) => t a -> (Key t -> a -> f b) -> f ()
+forWithKey1_ = flip traverseWithKey1_
+{-# INLINE forWithKey1_ #-}
+
+foldMapWithKeyDefault1 :: (FoldableWithKey1 t, Monoid m) => (Key t -> a -> m) -> t a -> m
+foldMapWithKeyDefault1 f = unwrapMonoid . foldMapWithKey (fmap WrapMonoid . f)
+{-# INLINE foldMapWithKeyDefault1 #-}
+
+-- * TraversableWithKey
+
+class (Keyed t, FoldableWithKey t, Traversable t) => TraversableWithKey t where
+  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) 
+
+instance TraversableWithKey f => TraversableWithKey (Cofree f) where
+  traverseWithKey f (a :< as) = (:<) <$> f Seq.empty a <*> traverseWithKey (traverseWithKey . fmap f . flip (|>)) as
+
+instance TraversableWithKey Tree where
+  traverseWithKey f (Node a as) = Node <$> f Seq.empty a <*> traverseWithKey (traverseWithKey . fmap f . flip (|>)) as
+
+instance TraversableWithKey f => TraversableWithKey (Free f) where
+  traverseWithKey f (Pure a) = Pure <$> f Seq.empty a
+  traverseWithKey f (Free as) = Free <$> traverseWithKey (traverseWithKey . fmap f . flip (|>)) as
+
+forWithKey :: (TraversableWithKey t, Applicative f) => t a -> (Key t -> a -> f b) -> f (t b)
+forWithKey = flip traverseWithKey
+{-# INLINE forWithKey #-}
+
+forWithKeyM :: (TraversableWithKey t, Monad m) => t a -> (Key t -> a -> m b) -> m (t b)
+forWithKeyM = flip mapWithKeyM
+{-# INLINE forWithKeyM #-}
+
+-- left-to-right state transformer
+newtype StateL s a = StateL { runStateL :: s -> (s, a) }
+
+instance Functor (StateL s) where
+  fmap f (StateL k) = StateL $ \ s ->
+    let (s', v) = k s in (s', f v)
+
+instance Applicative (StateL s) where
+  pure x = StateL (\ s -> (s, x))
+  StateL kf <*> StateL kv = StateL $ \ s ->
+    let (s', f) = kf s
+        (s'', v) = kv s'
+    in  (s'', f v)
+
+-- |The 'mapAccumWithKeyL' function behaves like a combination of 'mapWithKey'
+-- and 'foldlWithKey'; it applies a function to each element of a structure,
+-- passing an accumulating parameter from left to right, and returning
+-- a final value of this accumulator together with the new structure.
+mapAccumWithKeyL :: TraversableWithKey t => (Key t -> a -> b -> (a, c)) -> a -> t b -> (a, t c)
+mapAccumWithKeyL f s t = runStateL (traverseWithKey (\k b -> StateL (\a -> f k a b)) t) s
+{-# INLINE mapAccumWithKeyL #-}
+
+-- right-to-left state transformer
+newtype StateR s a = StateR { runStateR :: s -> (s, a) }
+
+instance Functor (StateR s) where
+  fmap f (StateR k) = StateR $ \ s ->
+    let (s', v) = k s in (s', f v)
+
+instance Applicative (StateR s) where
+  pure x = StateR (\ s -> (s, x))
+  StateR kf <*> StateR kv = StateR $ \ s ->
+    let (s', v) = kv s
+        (s'', f) = kf s'
+    in (s'', f v)
+
+-- |The 'mapAccumWithKeyR' function behaves like a combination of 'mapWithKey'
+-- and 'foldrWithKey'; it applies a function to each element of a structure,
+-- passing an accumulating parameter from right to left, and returning
+-- a final value of this accumulator together with the new structure.
+mapAccumWithKeyR :: TraversableWithKey t => (Key t -> a -> b -> (a, c)) -> a -> t b -> (a, t c)
+mapAccumWithKeyR f s t = runStateR (traverseWithKey (\k b -> StateR (\a -> f k a b)) t) s
+{-# INLINE mapAccumWithKeyR #-}
+
+mapWithKeyDefault :: TraversableWithKey t => (Key t -> a -> b) -> t a -> t b
+mapWithKeyDefault f = runIdentity . traverseWithKey (fmap Identity . f)
+{-# INLINE mapWithKeyDefault #-}
+
+-- | This function may be used as a value for `Data.Foldable.foldMapWithKey`
+-- in a `FoldableWithKey` instance.
+foldMapWithKeyDefault :: (TraversableWithKey t, Monoid m) => (Key t -> a -> m) -> t a -> m
+foldMapWithKeyDefault f = getConst . traverseWithKey (fmap Const . f)
+{-# INLINE foldMapWithKeyDefault #-}
+
+-- * TraverableWithKey1
+class (Traversable1 t, FoldableWithKey1 t, TraversableWithKey t) => TraversableWithKey1 t where
+  traverseWithKey1 :: Apply f => (Key t -> a -> f b) -> t a -> f (t b)
+
+-- 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
+
+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
+
+foldMapWithKey1Default :: (TraversableWithKey1 t, Semigroup m) => (Key t -> a -> m) -> t a -> m
+foldMapWithKey1Default f = getConst . traverseWithKey1 (\k -> Const . f k)
+{-# INLINE foldMapWithKey1Default #-}
+
+-- * Instances
+
+type instance Key Identity = ()
+
+instance Indexable Identity where
+  index (Identity a) _ = a
+
+instance Lookup Identity where
+  lookup _ (Identity a) = Just a
+
+instance Adjustable Identity where
+  adjust f _ (Identity a) = Identity (f a)
+  replace _ b _ = Identity b
+
+instance Zip Identity where
+  zipWith f (Identity a) (Identity b) = Identity (f a b)
+
+instance ZipWithKey Identity where
+  zipWithKey f (Identity a) (Identity b) = Identity (f () a b)
+
+instance Keyed Identity where
+  mapWithKey f = Identity . f () . runIdentity
+
+instance FoldableWithKey Identity where
+  foldrWithKey f z (Identity a) = f () a z
+
+instance FoldableWithKey1 Identity where
+  foldMapWithKey1 f (Identity a) = f () a
+
+instance TraversableWithKey Identity where
+  traverseWithKey f (Identity a) = Identity <$> f () a
+
+instance TraversableWithKey1 Identity where
+  traverseWithKey1 f (Identity a) = Identity <$> f () a
+
+type instance Key (IdentityT m) = Key m
+
+instance Indexable m => Indexable (IdentityT m) where
+  index (IdentityT m) i = index m i
+
+instance Lookup m => Lookup (IdentityT m) where
+  lookup i (IdentityT m) = lookup i m
+
+instance Zip m => Zip (IdentityT m) where
+  zipWith f (IdentityT m) (IdentityT n) = IdentityT (zipWith f m n)
+
+instance ZipWithKey m => ZipWithKey (IdentityT m) where
+  zipWithKey f (IdentityT m) (IdentityT n) = IdentityT (zipWithKey f m n)
+
+instance Keyed m => Keyed (IdentityT m) where
+  mapWithKey f = IdentityT . mapWithKey f . runIdentityT 
+
+instance FoldableWithKey m => FoldableWithKey (IdentityT m) where
+  foldrWithKey f z (IdentityT m) = foldrWithKey f z m
+
+instance FoldableWithKey1 m => FoldableWithKey1 (IdentityT m) where
+  foldMapWithKey1 f (IdentityT m) = foldMapWithKey1 f m
+
+instance TraversableWithKey m => TraversableWithKey (IdentityT m) where
+  traverseWithKey f (IdentityT a) = IdentityT <$> traverseWithKey f a
+
+instance TraversableWithKey1 m => TraversableWithKey1 (IdentityT m) where
+  traverseWithKey1 f (IdentityT a) = IdentityT <$> traverseWithKey1 f a
+
+type instance Key ((->)a) = a
+
+instance Keyed ((->)a) where
+  mapWithKey = (<*>)
+
+instance Zip ((->)a) where
+  zipWith f g h a = f (g a) (h a)
+
+instance ZipWithKey ((->)a) where
+  zipWithKey f g h a = f a (g a) (h a)
+
+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 (m a) (n a)
+
+instance ZipWithKey m => ZipWithKey (ReaderT e m) where
+  zipWithKey f (ReaderT m) (ReaderT n) = ReaderT $ \a -> 
+    zipWithKey (f . (,) a) (m a) (n a)
+
+instance Keyed m => Keyed (ReaderT e m) where
+  mapWithKey f (ReaderT m) = ReaderT $ \k -> mapWithKey (f . (,) k) (m k)
+
+instance Indexable m => Indexable (ReaderT e m) where
+  index (ReaderT f) (e,k) = index (f e) k
+
+instance Lookup m => Lookup (ReaderT e m) where
+  lookup (e,k) (ReaderT f) = lookup k (f e)
+
+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 (\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 (\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 
+
+instance Indexable w => Indexable (TracedT s w) where
+  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
+  zipWith = IntMap.intersectionWith
+
+instance ZipWithKey IntMap where
+  zipWithKey = IntMap.intersectionWithKey
+
+instance Keyed IntMap where
+  mapWithKey = IntMap.mapWithKey
+
+instance FoldableWithKey IntMap where
+  foldrWithKey = IntMap.foldWithKey
+
+instance TraversableWithKey IntMap where
+  traverseWithKey f = fmap IntMap.fromDistinctAscList . traverse (\(k, v) -> (,) k <$> f k v) . IntMap.toAscList
+
+instance Indexable IntMap where
+  index = (IntMap.!)
+
+instance Lookup IntMap where
+  lookup = IntMap.lookup
+
+instance Adjustable IntMap where
+  adjust = IntMap.adjust
+
+type instance Key (Compose f g) = (Key f, Key g)
+
+instance (Zip f, Zip g) => Zip (Compose f g) where
+  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 (zipWithKey . fmap f . (,)) a b
+
+instance (Keyed f, Keyed g) => Keyed (Compose f g) where
+  mapWithKey f = Compose . mapWithKey (\k -> mapWithKey (f . (,) k)) . getCompose
+
+instance (Indexable f, Indexable g) => Indexable (Compose f g) where
+  index (Compose fg) (i,j) = index (index fg i) j
+
+instance (Lookup f, Lookup g) => Lookup (Compose f g) where
+  lookup (i,j) (Compose fg) = lookup i fg >>= lookup j
+
+instance (FoldableWithKey f, FoldableWithKey m) => FoldableWithKey (Compose f m) where
+  foldMapWithKey f = foldMapWithKey (\k -> foldMapWithKey (f . (,) k)) . getCompose
+
+instance (FoldableWithKey1 f, FoldableWithKey1 m) => FoldableWithKey1 (Compose f m) where
+  foldMapWithKey1 f = foldMapWithKey1 (\k -> foldMapWithKey1 (f . (,) k)) . getCompose
+
+instance (TraversableWithKey f, TraversableWithKey m) => TraversableWithKey (Compose f m) where
+  traverseWithKey f = fmap Compose . traverseWithKey (\k -> traverseWithKey (f . (,) k)) . getCompose
+
+instance (TraversableWithKey1 f, TraversableWithKey1 m) => TraversableWithKey1 (Compose f m) where
+  traverseWithKey1 f = fmap Compose . traverseWithKey1 (\k -> traverseWithKey1 (f . (,) k)) . getCompose
+
+type instance Key [] = Int
+
+instance Zip [] where
+  zip = List.zip
+  zipWith = List.zipWith
+
+instance ZipWithKey [] where
+  zipWithKey f = go 0 where
+    go _ [] _ = []
+    go _ _ [] = []
+    go n (x:xs) (y:ys) = n' `seq` f n x y : go n' xs ys
+      where n' = n + 1 
+
+instance Keyed [] where
+  mapWithKey f xs0 = go xs0 0 where
+    go [] _ = []
+    go (x:xs) n = f n x : (go xs $! (n + 1))
+
+instance FoldableWithKey [] where
+  foldrWithKey f z0 xs0 = go z0 xs0 0 where
+    go z [] _ = z
+    go z (x:xs) n = f n x (go z xs $! (n + 1))
+
+instance TraversableWithKey [] where
+  traverseWithKey f xs0 = go xs0 0 where
+    go [] _ = pure []
+    go (x:xs) n = (:) <$> f n x <*> (go xs $! (n + 1))
+
+instance Indexable [] where
+  index = (!!)
+
+instance Lookup [] where
+  lookup = fmap listToMaybe . drop
+
+instance Adjustable [] where
+  adjust f 0 (x:xs) = f x : xs
+  adjust _ _ [] = []
+  adjust f n (x:xs) = n' `seq` x : adjust f n' xs where n' = n - 1
+
+
+
+instance Zip NonEmpty where
+  zipWith = NonEmpty.zipWith
+
+instance ZipWithKey NonEmpty where
+  zipWithKey f (a:|as) (b:|bs) = f 0 a b :| zipWithKey (f . (+1)) as bs
+
+instance Keyed NonEmpty where
+  mapWithKey f (a:|as) = f 0 a :| mapWithKey (f . (+1)) as
+
+instance FoldableWithKey NonEmpty where
+  foldrWithKey f z (x:|xs) = f 0 x (foldrWithKey (f . (+1)) z xs)
+
+instance TraversableWithKey NonEmpty where
+  traverseWithKey f (x :| xs) = (:|) <$> f 0 x <*> traverseWithKey (f . (+1)) xs
+
+instance Indexable NonEmpty where
+  index (x:|_) 0 = x
+  index (_:|xs) i = xs !! (i - 1)
+
+instance Lookup NonEmpty where
+  lookup 0 (x:|_) = Just x
+  lookup n (_:|xs) = lookup (n - 1) xs
+
+instance Adjustable NonEmpty where
+  adjust f 0 (x:|xs) = f x :| xs
+  adjust f n (x:|xs) = x :| adjust f (n - 1) xs
+
+instance FoldableWithKey1 NonEmpty where
+  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
+  traverseWithKey1 f (x:|[]) = (:|[]) <$> f 0 x
+  traverseWithKey1 f (x:|(y:ys)) = (\w (z:|zs) -> w :| (z:zs)) <$> f 0 x <.> traverseWithKey1 (f . (+1)) (y :| ys)
+
+type instance Key Seq = Int
+
+instance Indexable Seq where
+  index = Seq.index
+
+instance Lookup Seq where
+  lookup i s = case viewl (Seq.drop i s) of
+    EmptyL -> Nothing
+    a Seq.:< _ -> Just a
+
+instance Zip Seq where
+  zip = Seq.zip
+  zipWith = Seq.zipWith
+
+instance ZipWithKey Seq where
+  zipWithKey f a b = Seq.zipWith id (Seq.mapWithIndex f a) b
+
+instance Adjustable Seq where
+  adjust = Seq.adjust
+
+instance Keyed Seq where
+  mapWithKey = Seq.mapWithIndex
+
+instance FoldableWithKey Seq where
+  foldrWithKey = Seq.foldrWithIndex
+
+instance TraversableWithKey Seq where
+  traverseWithKey f = fmap Seq.fromList . traverseWithKey f . toList
+
+type instance Key (Map k) = k
+
+instance Ord k => Zip (Map k) where
+  zipWith = Map.intersectionWith
+
+instance Ord k => ZipWithKey (Map k) where
+  zipWithKey = Map.intersectionWithKey
+
+instance Keyed (Map k) where
+  mapWithKey = Map.mapWithKey
+
+instance Ord k => Indexable (Map k) where
+  index = (Map.!)
+
+instance Ord k => Lookup (Map k) where
+  lookup = Map.lookup
+
+instance FoldableWithKey (Map k) where
+  foldrWithKey = Map.foldrWithKey
+
+instance TraversableWithKey (Map k) where
+  traverseWithKey f = fmap Map.fromDistinctAscList . traverse (\(k, v) -> (,) k <$> f k v) . Map.toAscList
+
+instance Ord k => Adjustable (Map k) where
+  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.!)
+
+instance Ix i => Lookup (Array i) where
+  lookup i arr
+    | inRange (Array.bounds arr) i = Just (arr Array.! i)
+    | otherwise = Nothing
+
+instance Ix i => FoldableWithKey (Array i) where
+  foldrWithKey f z = Prelude.foldr (uncurry f) z . Array.assocs
+
+instance Ix i => TraversableWithKey (Array i) where
+  traverseWithKey f arr = Array.listArray (Array.bounds arr) <$> traverse (uncurry f) (Array.assocs arr)
+
+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
+
+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 (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))
+
+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 _ b) (Right j) = index b j
+
+instance (Lookup f, Lookup g) => Lookup (Product f g) where
+  lookup (Left i) (Pair a _) = lookup i a
+  lookup (Right j) (Pair _ b) = lookup j b
+
+instance (Zip f, Zip g) => Zip (Product f g) where
+  zipWith f (Pair a b) (Pair c d) = Pair (zipWith f a c) (zipWith f b d)
+
+instance (ZipWithKey f, ZipWithKey g) => ZipWithKey (Product f g) where
+  zipWithKey f (Pair a b) (Pair c d) = Pair (zipWithKey (f . Left) a c) (zipWithKey (f . Right) b d)
+
+-- interleave?
+instance (FoldableWithKey f, FoldableWithKey g) => FoldableWithKey (Product f g) where
+  foldMapWithKey f (Pair a b) = foldMapWithKey (f . Left) a `mappend` foldMapWithKey (f . Right) b
+
+instance (FoldableWithKey1 f, FoldableWithKey1 g) => FoldableWithKey1 (Product f g) where
+  foldMapWithKey1 f (Pair a b) = foldMapWithKey1 (f . Left) a <> foldMapWithKey1 (f . Right) b
+
+instance (TraversableWithKey f, TraversableWithKey g) => TraversableWithKey (Product f g) where
+  traverseWithKey f (Pair a b) = Pair <$> traverseWithKey (f . Left) a <*> traverseWithKey (f . Right) b
+
+instance (TraversableWithKey1 f, TraversableWithKey1 g) => TraversableWithKey1 (Product f g) where
+  traverseWithKey1 f (Pair a b) = Pair <$> traverseWithKey1 (f . Left) a <.> traverseWithKey1 (f . Right) b
+
+instance (Adjustable f, Adjustable g) => Adjustable (Product f g) where
+  adjust f (Left i) (Pair a b)  = Pair (adjust f i a) b
+  adjust f (Right j) (Pair a b) = Pair a (adjust f j b)
+  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)
+