diff --git a/src/PDF.hs b/src/PDF.hs index 18ad7e6..36d276b 100644 --- a/src/PDF.hs +++ b/src/PDF.hs @@ -2,9 +2,9 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} module PDF ( - AllLayers(..) - , Document(..) - , EOLStyleK(..) + Document(..) + , EOLStyle(..) + , 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 AllLayers = AllLayers +data EOLStyle = EOLStyle +data Layers = Layers data UnifiedLayers = UnifiedLayers -instance Monad m => Box m EOLStyleK Document EOL.Style where - r EOLStyleK = return . eolStyle - w EOLStyleK document eolStyle = return $ document {eolStyle} +instance Monad m => Box m EOLStyle Document EOL.Style where + r EOLStyle = return . 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 - r AllLayers = return . layers - w AllLayers document layers = return $ document {layers = layers} +instance Monad m => Box m Layers Document [Layer] where + r Layers = return . layers + w Layers layers document = return $ document {layers = layers} render :: Document -> Lazy.ByteString render document@(Document {eolStyle}) = Output.render eolStyle document diff --git a/src/PDF/Box.hs b/src/PDF/Box.hs index 11332f0..23a711f 100644 --- a/src/PDF/Box.hs +++ b/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 -edit i f a = - r i a >>= f >>= w i a +at :: Box m i a b => i -> (b -> m b) -> a -> m a +at i f a = r i a >>= f >>= flip (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 +atAll :: (Traversable t, Monad m, Box m i a (t b)) => i -> (b -> m b) -> a -> m a +atAll i f = at i $ (mapM 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 +edit :: MonadState a m => (a -> m a) -> m () +edit f = get >>= f >>= put 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) -(.@) = (,) diff --git a/src/PDF/Layer.hs b/src/PDF/Layer.hs index 3b86e76..e0e3a31 100644 --- a/src/PDF/Layer.hs +++ 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 - r AllObjects = return . objects - w AllObjects layer@(Layer {occurrences, docStructure}) newObjects = +instance Monad m => Box m Objects Layer (Map ObjectId Object) where + r Objects = return . objects + w Objects newObjects layer@(Layer {occurrences, docStructure}) = return $ layer { occurrences = keptOccurrences ++ newOccurrences , objects = newObjects