Once again something that should never have been committed
This commit is contained in:
parent
c491e8a70c
commit
f6664683c7
|
|
@ -1,130 +0,0 @@
|
|||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
module PDF.Object.Navigation (
|
||||
Error(..)
|
||||
, Except
|
||||
, PDFContent
|
||||
, Clear(..)
|
||||
, Raw(..)
|
||||
, (./)
|
||||
, (//)
|
||||
, (>./)
|
||||
, (>//)
|
||||
, castObject
|
||||
, getDictionary
|
||||
, getKey
|
||||
, objectById
|
||||
, origin
|
||||
) where
|
||||
|
||||
import Codec.Compression.Zlib (compress, decompress)
|
||||
import Control.Applicative (Alternative(..))
|
||||
import Control.Monad (MonadPlus(..))
|
||||
import Control.Monad.Reader (MonadReader(..), ReaderT)
|
||||
import Control.Monad.Fail (MonadFail(..))
|
||||
import Data.ByteString (ByteString)
|
||||
import qualified Data.ByteString.Lazy as Lazy (ByteString, fromStrict, toStrict)
|
||||
import Data.Map ((!))
|
||||
import qualified Data.Map as Map (lookup)
|
||||
import PDF.Box (Box(..))
|
||||
import PDF.Layer (Layer(..))
|
||||
import PDF.Object (
|
||||
Dictionary, DirectObject(..), IndirectObjCoordinates(..)
|
||||
, Name(..), Object(..), Structure(..)
|
||||
)
|
||||
import PDF.Output (ObjectId)
|
||||
import Prelude hiding (fail)
|
||||
import Text.Printf (printf)
|
||||
|
||||
type Except m = (Alternative m, MonadFail m)
|
||||
type PDFContent m = ReaderT Layer m
|
||||
newtype Error a = Error {
|
||||
runError :: Either String a
|
||||
} deriving (Alternative, Functor, Applicative, Monad, MonadPlus)
|
||||
instance MonadFail Error where
|
||||
fail = Error . Left
|
||||
type Component = String
|
||||
|
||||
getDictionary :: Except m => Object -> PDFContent m Dictionary
|
||||
getDictionary (Direct (Dictionary aDict)) = return aDict
|
||||
getDictionary (Direct (Reference (IndirectObjCoordinates {objectId}))) =
|
||||
objectById objectId >>= getDictionary
|
||||
getDictionary (Stream {header}) = return header
|
||||
getDictionary obj = expected "dictionary : " obj
|
||||
|
||||
expected :: (MonadFail m, Show a) => String -> a -> m b
|
||||
expected name = fail . printf "Not a %s: %s" name . show
|
||||
|
||||
getKey :: Except m => String -> Object -> PDFContent m DirectObject
|
||||
getKey key object = getDictionary object >>= catchMaybe . Map.lookup (Name key)
|
||||
where
|
||||
errorMessage =
|
||||
printf "Key %s not found in object %s" key (show object)
|
||||
catchMaybe = maybe (fail errorMessage) return
|
||||
|
||||
objectById :: Except m => ObjectId -> PDFContent m Object
|
||||
objectById objectId = do
|
||||
layer <- ask
|
||||
return (objects layer ! objectId)
|
||||
|
||||
(./) :: Except m => PDFContent m Object -> Component -> PDFContent m Object
|
||||
(./) object key = (object >>= getKey key >>= castObject)
|
||||
|
||||
castObject :: Except m => DirectObject -> PDFContent m Object
|
||||
castObject (Reference (IndirectObjCoordinates {objectId})) =
|
||||
objectById objectId
|
||||
castObject directObject = return $ Direct directObject
|
||||
|
||||
(//) :: Except m => PDFContent m Object -> [Component] -> PDFContent m Object
|
||||
(//) object [] = object
|
||||
(//) object (key:keys) = object ./ key // keys
|
||||
|
||||
(>./) :: Except m => Object -> Component -> PDFContent m Object
|
||||
(>./) object = (return object ./)
|
||||
|
||||
(>//) :: Except m => Object -> [Component] -> PDFContent m Object
|
||||
(>//) object = (return object //)
|
||||
|
||||
origin :: Except m => PDFContent m Object
|
||||
origin = Direct . Dictionary . trailer . docStructure <$> ask
|
||||
|
||||
data Clear = Clear
|
||||
data Raw = Raw
|
||||
|
||||
onLazy :: (Lazy.ByteString -> Lazy.ByteString) -> ByteString -> ByteString
|
||||
onLazy f = Lazy.toStrict . f . Lazy.fromStrict
|
||||
|
||||
contains :: String -> DirectObject -> Bool
|
||||
contains needle (NameObject (Name n)) = needle == n
|
||||
contains needle (Array directObjects) = oneOf directObjects (contains needle)
|
||||
where
|
||||
oneOf [] _ = False
|
||||
oneOf (x:xs) p = p x || oneOf xs p
|
||||
contains _ _ = False
|
||||
|
||||
instance MonadFail m => Box m Clear Object ByteString where
|
||||
r Clear (Stream {header, streamContent}) = return $
|
||||
case Map.lookup (Name "Filter") header of
|
||||
Just directObject
|
||||
| contains "FlateDecode" directObject -> onLazy decompress streamContent
|
||||
_ -> streamContent
|
||||
r _ obj = expected "stream" obj
|
||||
|
||||
w Clear streamContent obj@(Stream {header}) = return $
|
||||
case Map.lookup (Name "Filter") header of
|
||||
Just directObject
|
||||
| contains "FlateDecode" directObject ->
|
||||
obj {streamContent = onLazy compress streamContent}
|
||||
_ -> obj {streamContent}
|
||||
w _ _ obj = expected "stream" obj
|
||||
|
||||
instance MonadFail m => Box m Raw Object ByteString where
|
||||
r Raw (Stream {streamContent}) = return streamContent
|
||||
r _ obj = expected "stream" obj
|
||||
|
||||
w Raw streamContent obj@(Stream {}) = return $ obj {streamContent}
|
||||
w _ _ obj = expected "stream" obj
|
||||
Loading…
Reference in New Issue