Implement 'w' for Pages Box instances

This commit is contained in:
Tissevert 2020-03-17 08:46:37 +01:00
parent ee5e7500a8
commit 24630a04a1
1 changed files with 20 additions and 5 deletions

View File

@ -17,27 +17,30 @@ import Control.Applicative (Alternative, (<|>))
import Control.Monad (foldM) import Control.Monad (foldM)
import Control.Monad.Fail (MonadFail(..)) import Control.Monad.Fail (MonadFail(..))
import Control.Monad.Reader (ReaderT, runReaderT) import Control.Monad.Reader (ReaderT, runReaderT)
import Control.Monad.State (StateT(..), evalStateT, gets, modify) import Control.Monad.State (StateT(..), evalStateT, execStateT, gets, modify)
import Control.Monad.Trans (lift) import Control.Monad.Trans (lift)
import Data.ByteString.Lazy (toStrict)
import Data.Id (Id) import Data.Id (Id)
import Data.Map (Map) import Data.Map (Map)
import qualified Data.Map as Map (empty, fromList, insert, lookup, toList) import qualified Data.Map as Map (empty, fromList, insert, lookup, toList)
import Data.OrderedMap (OrderedMap, build) import Data.OrderedMap (OrderedMap, build, mapi)
import PDF.Box (Box(..)) import PDF.Box (Box(..), at, edit)
import PDF.CMap (cMap) import PDF.CMap (cMap)
import PDF.Content (Content(..)) import PDF.Content (Content(..))
import qualified PDF.Content as Content (parse) import qualified PDF.Content as Content (parse)
import PDF.Encoding (encoding) import PDF.Encoding (encoding)
import PDF.EOL (Style(..))
import PDF.Font (Font, FontSet) import PDF.Font (Font, FontSet)
import PDF.Layer (Layer(..)) import PDF.Layer (Layer(..), Objects(..))
import PDF.Object ( import PDF.Object (
Dictionary, DirectObject(..), IndirectObjCoordinates(..) Dictionary, DirectObject(..), IndirectObjCoordinates(..)
, Name(..), Object(..) , Name(..), Object(..)
,) ,)
import PDF.Object.Navigation ( import PDF.Object.Navigation (
Clear(..), PDFContent, (//), (>./), (>//), getDictionary Clear(..), (//), (>./), (>//), getDictionary
, getKey, objectById, origin , getKey, objectById, origin
) )
import PDF.Output (render)
import Prelude hiding (fail) import Prelude hiding (fail)
import Text.Printf (printf) import Text.Printf (printf)
@ -113,6 +116,13 @@ pagesList =
getReferences (Array kids) = kids >>= getReference getReferences (Array kids) = kids >>= getReference
getReferences _ = fail "Not a pages array" getReferences _ = fail "Not a pages array"
updatePage :: MonadFail m => Page -> StateT Layer m ()
updatePage (Page {contents}) = sequence_ $ mapi updateContent contents
where
updateContent source content =
edit . at Objects . at source . at Clear $ setContent content
setContent content _ = return . toStrict $ render LF content
data Pages = Pages data Pages = Pages
newtype PageNumber = P Int newtype PageNumber = P Int
data Contents = Contents data Contents = Contents
@ -123,6 +133,8 @@ instance (Alternative m, MonadFail m) => Box m Pages Layer (Map Int Page) where
numbered :: [Page] -> Map Int Page numbered :: [Page] -> Map Int Page
numbered = Map.fromList . zip [1..] numbered = Map.fromList . zip [1..]
w Pages pages = execStateT $ mapM_ updatePage pages
instance (Alternative m, MonadFail m) => Box m PageNumber Layer Page where instance (Alternative m, MonadFail m) => Box m PageNumber Layer Page where
r (P i) layer r (P i) layer
| i < 1 = fail "Pages start at 1" | i < 1 = fail "Pages start at 1"
@ -131,8 +143,11 @@ instance (Alternative m, MonadFail m) => Box m PageNumber Layer Page where
firstPage [] = fail "Page is out of bounds" firstPage [] = fail "Page is out of bounds"
firstPage (p:_) = loadPage p firstPage (p:_) = loadPage p
w _ page = execStateT $ updatePage page
instance Monad m => Box m Contents Page (OrderedMap (Id Object) Content) where instance Monad m => Box m Contents Page (OrderedMap (Id Object) Content) where
r Contents = return . contents r Contents = return . contents
w _ contents page = return $ page {contents}
cacheFonts :: Monad m => StateT CachedFonts m a -> m a cacheFonts :: Monad m => StateT CachedFonts m a -> m a
cacheFonts = flip evalStateT Map.empty cacheFonts = flip evalStateT Map.empty