Generalize the Box instances on containers from the particular cases of Document/Layers and Layers/Objects and move them to PDF.Box

src/PDF.hs

@@ -10,7 +10,6 @@ module PDF (
     , render
   ) where
 
-import Control.Monad.Fail (MonadFail(..))
 import Data.ByteString.Char8 (ByteString)
 import qualified Data.ByteString.Char8 as BS (
     drop, findIndex, head, isPrefixOf, last, length, span, unpack
@@ -19,7 +18,7 @@ import Data.ByteString.Char8.Util (previous, subBS)
 import qualified Data.ByteString.Lazy as Lazy (ByteString)
 import qualified Data.Map as Map (lookup)
 import PDF.Body (populate)
-import PDF.Box (Box(..), edit)
+import PDF.Box (Box(..))
 import qualified PDF.EOL as EOL (Style(..), charset, parser)
 import PDF.Layer (Layer, unify)
 import PDF.Object (
@@ -30,7 +29,6 @@ import PDF.Object (
 import qualified PDF.Output as Output (render, line)
 import PDF.Output (Output(..))
 import PDF.Parser (Parser, evalParser, string, takeAll)
-import Prelude hiding (fail)
 import Text.Printf (printf)
 
 data Document = Document {
@@ -60,18 +58,6 @@ instance Monad m => Box m AllLayers Document [Layer] where
   r AllLayers = return . layers
   w AllLayers document layers = return $ document {layers = layers}
 
-instance MonadFail m => Box m Int Document Layer where
-  r i = at i . layers
-    where
-      at _ [] = fail $ "Layer out of bounds " ++ show i
-      at 0 (x:_) = return x
-      at k (_:xs) = at (k+1) xs
-  w i document layer = edit AllLayers (setAt i) document
-    where
-      setAt _ [] = fail $ "Layer out of bounds " ++ show i
-      setAt 0 (_:xs) = return (layer:xs)
-      setAt k (x:xs) = (x:)<$>(setAt (k-1) xs)
-
 render :: Document -> Lazy.ByteString
 render document@(Document {eolStyle}) = Output.render eolStyle document
 

src/PDF/Box.hs

@@ -5,12 +5,21 @@
 {-# LANGUAGE UndecidableInstances #-}
 module PDF.Box (
       Box(..)
+    , I(..)
     , (.@)
+    , at
     , edit
+    , forAll
     , modifyAt
   ) where
 
+import Control.Monad.Fail (MonadFail(..))
 import Control.Monad.State (MonadState(..))
+import Data.Map (Map)
+import qualified Data.Map as Map (insert, lookup, member)
+import Prelude hiding (fail)
+
+data I = I Int
 
 class Monad m => Box m i a b | m a i -> b where
   r :: i -> a -> m b
@@ -20,13 +29,38 @@ edit :: Box m i a b => i -> (b -> m b) -> a -> m a
 edit i f a =
   r i a >>= f >>= w i a
 
+at :: (MonadState a m, Box m i a b) => i -> (b -> m c) -> m c
+at i f = get >>= r i >>= f
+
 modifyAt :: (MonadState a m, Box m i a b) => i -> (b -> m b) -> m ()
 modifyAt i f = get >>= edit i 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
+    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
+    where
+      setAt _ [] = fail $ "Index out of bounds " ++ show i
+      setAt 0 (_:xs) = return (newX:xs)
+      setAt k (x:xs) = (x:)<$>(setAt (k-1) xs)
+
+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
+    | Map.member k aMap =
+        return $ Map.insert k a aMap
+    | otherwise = fail "Unknown key"
+
 infixr 6 .@
 (.@) :: a -> b -> (a, b)
 (.@) = (,)

src/PDF/Layer.hs

@@ -7,11 +7,8 @@ module PDF.Layer (
     , unify
   ) where
 
-import Control.Monad.Fail (MonadFail(..))
 import Data.Map (Map, (!), mapWithKey, member)
-import qualified Data.Map as Map (
-    empty, insert, keysSet, lookup, member, union
-  )
+import qualified Data.Map as Map (empty, keysSet, member, union)
 import qualified Data.Set as Set (delete, toList)
 import PDF.Box (Box(..))
 import PDF.Object (
@@ -23,7 +20,6 @@ import PDF.Output (
       ObjectId, Offset(..), Output(..), Resource(..), byteString, getOffset
     , getOffsets, newLine
   )
-import Prelude hiding (fail)
 import Text.Printf (printf)
 
 data Layer = Layer {
@@ -77,15 +73,6 @@ instance Monad m => Box m AllObjects Layer (Map ObjectId Object) where
         Indirect (IndirectObjCoordinates {objectId, versionNumber = 0})
       newOccurrences = makeOccurrence <$> Set.toList newObjectIds
 
-instance MonadFail m => Box m ObjectId Layer Object where
-  r objectId = maybe (fail errorMsg) return . Map.lookup objectId . objects
-    where
-      errorMsg = "Unknown " ++ show objectId
-  w objectId layer@(Layer {objects}) object
-    | Map.member objectId objects =
-        return $ layer {objects = Map.insert objectId object objects}
-    | otherwise = fail $ "Unknown " ++ show objectId
-
 emptyLayer :: Layer
 emptyLayer = Layer {
       docStructure = Structure {xRef = Map.empty, trailer = Map.empty}