Found a nicer formulation that doesn't require transitivity or index agglomeration and swapped argument of w for more reusability with at / atAll

src/PDF.hs

@@ -2,9 +2,9 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 module PDF (
-      AllLayers(..)
+      Document(..)
-    , Document(..)
+    , EOLStyle(..)
-    , EOLStyleK(..)
+    , Layers(..)
     , UnifiedLayers(..)
     , parseDocument
     , render
@@ -42,21 +42,21 @@ instance Output Document where
       Output.line (printf "%%PDF-%s" pdfVersion)
     `mappend` output layers
 
-data EOLStyleK = EOLStyleK
+data EOLStyle = EOLStyle
-data AllLayers = AllLayers
+data Layers = Layers
 data UnifiedLayers = UnifiedLayers
 
-instance Monad m => Box m EOLStyleK Document EOL.Style where
+instance Monad m => Box m EOLStyle Document EOL.Style where
-  r EOLStyleK = return . eolStyle
+  r EOLStyle = return . eolStyle
-  w EOLStyleK document eolStyle = return $ document {eolStyle}
+  w EOLStyle eolStyle document = return $ document {eolStyle}
 
 instance Monad m => Box m UnifiedLayers Document Layer where
   r UnifiedLayers = return . unify . layers
-  w UnifiedLayers document layer = w AllLayers document [layer]
+  w UnifiedLayers layer = w Layers [layer]
 
-instance Monad m => Box m AllLayers Document [Layer] where
+instance Monad m => Box m Layers Document [Layer] where
-  r AllLayers = return . layers
+  r Layers = return . layers
-  w AllLayers document layers = return $ document {layers = layers}
+  w Layers layers document = return $ document {layers = layers}
 
 render :: Document -> Lazy.ByteString
 render document@(Document {eolStyle}) = Output.render eolStyle document

src/PDF/Box.hs

@@ -6,11 +6,9 @@
 module PDF.Box (
       Box(..)
     , I(..)
-    , (.@)
     , at
+    , atAll
     , edit
-    , forAll
-    , modifyAt
   ) where
 
 import Control.Monad.Fail (MonadFail(..))
@@ -19,28 +17,20 @@ import Data.Map (Map)
 import qualified Data.Map as Map (insert, lookup, member)
 import Prelude hiding (fail)
 
-data I = I Int
+newtype I = I Int
 
 class Monad m => Box m i a b | m a i -> b where
   r :: i -> a -> m b
-  w :: i -> a -> b -> m a
+  w :: i -> b -> a -> m a
 
-edit :: Box m i a b => i -> (b -> m b) -> a -> m a
+at :: Box m i a b => i -> (b -> m b) -> a -> m a
-edit i f a =
+at i f a = r i a >>= f >>= flip (w i) a
-  r i a >>= f >>= w i a
 
-at :: (MonadState a m, Box m i a b) => i -> (b -> m c) -> m c
+atAll :: (Traversable t, Monad m, Box m i a (t b)) => i -> (b -> m b) -> a -> m a
-at i f = get >>= r i >>= f
+atAll i f = at i $ (mapM f)
 
-modifyAt :: (MonadState a m, Box m i a b) => i -> (b -> m b) -> m ()
+edit :: MonadState a m => (a -> m a) -> m ()
-modifyAt i f = get >>= edit i f >>= put
+edit f = get >>= f >>= put
-
-forAll :: (MonadState a m, Box m i a (t b)) => i -> (b -> m ()) -> m ()
-forAll = undefined
-
-instance (Box m i a b, Box m j b c) => Box m (i, j) a c where
-  r (i, j) a = r i a >>= r j
-  w (i, j) a c = edit i (flip (w j) c) a
 
 instance MonadFail m => Box m I [a] a where
   r (I i) = getAt i
@@ -48,7 +38,7 @@ instance MonadFail m => Box m I [a] a where
       getAt _ [] = fail $ "Index out of bounds " ++ show i
       getAt 0 (x:_) = return x
       getAt k (_:xs) = getAt (k+1) xs
-  w (I i) l newX = setAt i l
+  w (I i) newX = setAt i
     where
       setAt _ [] = fail $ "Index out of bounds " ++ show i
       setAt 0 (_:xs) = return (newX:xs)
@@ -56,11 +46,7 @@ instance MonadFail m => Box m I [a] a where
 
 instance (Ord k, MonadFail m) => Box m k (Map k a) a where
   r k = maybe (fail "Unknown key") return . Map.lookup k
-  w k aMap a
+  w k a aMap
     | Map.member k aMap =
         return $ Map.insert k a aMap
     | otherwise = fail "Unknown key"
-
-infixr 6 .@
-(.@) :: a -> b -> (a, b)
-(.@) = (,)

src/PDF/Layer.hs

@@ -2,8 +2,8 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 module PDF.Layer (
-      AllObjects(..)
+      Layer(..)
-    , Layer(..)
+    , Objects(..)
     , unify
   ) where
 
@@ -50,11 +50,11 @@ instance Output Layer where
     where
       Structure {xRef, trailer} = docStructure
 
-data AllObjects = AllObjects
+data Objects = Objects
 
-instance Monad m => Box m AllObjects Layer (Map ObjectId Object) where
+instance Monad m => Box m Objects Layer (Map ObjectId Object) where
-  r AllObjects = return . objects
+  r Objects = return . objects
-  w AllObjects layer@(Layer {occurrences, docStructure}) newObjects =
+  w Objects newObjects layer@(Layer {occurrences, docStructure}) =
     return $ layer {
           occurrences = keptOccurrences ++ newOccurrences
         , objects = newObjects