{-# LANGUAGE OverloadedStrings #-}
-- | Font dictionary
module Pdf.Document.FontDict
(
FontDict,
FontSubtype(..),
fontDictSubtype,
fontDictLoadInfo,
)
where
import Pdf.Core.Object
import Pdf.Core.Object.Util
import Pdf.Core.Exception
import Pdf.Core.Util
import Pdf.Core.Types
import qualified Pdf.Core.Name as Name
import Pdf.Content
import Pdf.Document.Pdf
import Pdf.Document.Internal.Types
import Data.Word
import Data.ByteString (ByteString)
import qualified Data.Vector as Vector
import qualified Data.HashMap.Strict as HashMap
import Control.Monad
import Control.Exception hiding (throw)
import qualified System.IO.Streams as Streams
import Data.Text.Encoding (decodeUtf8With)
import Data.Text.Encoding.Error (ignore)
import qualified Data.Text as Text
-- | Font subtypes
data FontSubtype
= FontType0
| FontType1
| FontMMType1
| FontType3
| FontTrueType
deriving (Show, Eq)
-- | Get font subtype
fontDictSubtype :: FontDict -> IO FontSubtype
fontDictSubtype (FontDict pdf dict) = do
obj <- sure (HashMap.lookup "Subtype" dict
`notice` "Subtype should exist")
>>= deref pdf
str <- sure $ nameValue obj `notice` "Subtype should be a name"
case str of
"Type0" -> return FontType0
"Type1" -> return FontType1
"MMType1" -> return FontMMType1
"Type3" -> return FontType3
"TrueType" -> return FontTrueType
_ -> throwIO $ Unexpected ("Unexpected font subtype: " ++ show str) []
-- | Load font info for the font
fontDictLoadInfo :: FontDict -> IO FontInfo
fontDictLoadInfo fd@(FontDict pdf fontDict) = do
subtype <- fontDictSubtype fd
case subtype of
FontType0 -> FontInfoComposite <$> loadFontInfoComposite pdf fontDict
FontType3 -> do
fi <- loadFontInfoSimple pdf fontDict
obj <- sure (HashMap.lookup "FontMatrix" fontDict
`notice` "FontMatrix should exist")
>>= deref pdf
arr <- sure $ arrayValue obj
`notice` "FontMatrix should be an array"
fontMatrix <-
case mapM realValue (Vector.toList arr) of
Just [a, b, c, d, e, f] -> do
return $ Transform a b c d e f
Nothing -> throwIO $ Corrupted "FontMatrics should contain numbers" []
_ -> throwIO $ Corrupted "FontMatrix: wrong number of elements" []
return $ FontInfoSimple fi {
fiSimpleFontMatrix = fontMatrix
}
_ -> FontInfoSimple <$> loadFontInfoSimple pdf fontDict
loadFontInfoComposite :: Pdf -> Dict -> IO FIComposite
loadFontInfoComposite pdf fontDict = do
toUnicode <- loadUnicodeCMap pdf fontDict
descFont <- do
descFontObj <- sure (HashMap.lookup "DescendantFonts" fontDict
`notice` "DescendantFonts should exist")
>>= deref pdf
descFontArr <- sure $ arrayValue descFontObj
`notice` "DescendantFonts should be an array"
case Vector.toList descFontArr of
[o] -> do
o' <- deref pdf o
sure $ dictValue o'
`notice` "DescendantFonts element should be a dictionary"
_ -> throwIO $ Corrupted
"Unexpected value of DescendantFonts key in font dictionary" []
defaultWidth <-
case HashMap.lookup "DW" descFont of
Nothing -> return 1000
Just o -> do
o' <- deref pdf o
sure $ realValue o' `notice` "DW should be real"
widths <-
case HashMap.lookup "W" descFont of
Nothing -> return mempty
Just o -> do
o' <- deref pdf o
arr <- sure (arrayValue o' `notice` "W should be an array")
>>= Vector.mapM (deref pdf)
sure $ makeCIDFontWidths arr
fontDescriptor <- loadFontDescriptor pdf descFont
return $ FIComposite {
fiCompositeUnicodeCMap = toUnicode,
fiCompositeWidths = widths,
fiCompositeDefaultWidth = defaultWidth,
fiCompositeFontDescriptor = fontDescriptor
}
loadFontInfoSimple :: Pdf -> Dict -> IO FISimple
loadFontInfoSimple pdf fontDict = do
toUnicode <- loadUnicodeCMap pdf fontDict
encoding <-
case HashMap.lookup "Encoding" fontDict of
Just (Name "WinAnsiEncoding") -> return $ Just SimpleFontEncoding
{ simpleFontBaseEncoding = FontBaseEncodingWinAnsi
, simpleFontDifferences = []
}
Just (Name "MacRomanEncoding") -> return $ Just SimpleFontEncoding
{ simpleFontBaseEncoding = FontBaseEncodingMacRoman
, simpleFontDifferences = []
}
Just o -> do
o' <- deref pdf o
encDict <- sure (dictValue o'
`notice` "Encoding should be a dictionary")
case HashMap.lookup "BaseEncoding" encDict of
Just (Name "WinAnsiEncoding") -> do
diffs <- loadEncodingDifferences pdf encDict
return $ Just SimpleFontEncoding
{ simpleFontBaseEncoding = FontBaseEncodingWinAnsi
, simpleFontDifferences = diffs
}
Just (Name "MacRomanEncoding") -> do
diffs <- loadEncodingDifferences pdf encDict
return $ Just SimpleFontEncoding
{ simpleFontBaseEncoding = FontBaseEncodingMacRoman
, simpleFontDifferences = diffs
}
Nothing -> do
diffs <- loadEncodingDifferences pdf encDict
return $ Just SimpleFontEncoding
-- XXX: should be StandardEncoding?
{ simpleFontBaseEncoding = FontBaseEncodingWinAnsi
, simpleFontDifferences = diffs
}
_ -> return Nothing
_ -> return Nothing
widths <-
case HashMap.lookup "Widths" fontDict of
Nothing -> return Nothing
Just v -> do
v' <- deref pdf v
array <- sure $ arrayValue v'
`notice` "Widths should be an array"
widths <- forM (Vector.toList array) $ \o ->
sure (realValue o `notice` "Widths elements should be real")
firstChar <- sure $ (HashMap.lookup "FirstChar" fontDict >>= intValue)
`notice` "FirstChar should be an integer"
lastChar <- sure $ (HashMap.lookup "LastChar" fontDict >>= intValue)
`notice` "LastChar should be an integer"
return $ Just (firstChar, lastChar, widths)
fontDescriptor <- loadFontDescriptor pdf fontDict
return $ FISimple
{ fiSimpleUnicodeCMap = toUnicode
, fiSimpleEncoding = encoding
, fiSimpleWidths = widths
, fiSimpleFontMatrix = scale 0.001 0.001
, fiSimpleFontDescriptor = fontDescriptor
}
loadEncodingDifferences :: Pdf -> Dict -> IO [(Word8, ByteString)]
loadEncodingDifferences pdf dict = do
case HashMap.lookup "Differences" dict of
Nothing -> return []
Just v -> do
v' <- deref pdf v
arr <- sure $ arrayValue v'
`notice` "Differences should be an array"
case Vector.toList arr of
[] -> return []
(o : rest) -> do
n' <- fromIntegral <$> (sure $ intValue o
`notice` "Differences: the first element should be integer")
go [] n' rest
where
go res _ [] = return res
go res n (o:rest) =
case o of
(Number _) -> do
n' <- fromIntegral <$> (sure $ intValue o
`notice` "Differences: elements should be integers")
go res n' rest
(Name name) -> go (((n, Name.toByteString name)) : res) (n + 1) rest
_ -> throwIO $ Corrupted
("Differences array: unexpected object: " ++ show o) []
loadUnicodeCMap :: Pdf -> Dict -> IO (Maybe UnicodeCMap)
loadUnicodeCMap pdf fontDict =
case HashMap.lookup "ToUnicode" fontDict of
Nothing -> return Nothing
Just o -> do
ref <- sure $ refValue o
`notice` "ToUnicode should be a reference"
toUnicode <- lookupObject pdf ref
case toUnicode of
Stream s -> do
is <- streamContent pdf ref s
content <- mconcat <$> Streams.toList is
case parseUnicodeCMap content of
Left e -> throwIO $ Corrupted ("can't parse cmap: " ++ show e) []
Right cmap -> return $ Just cmap
_ -> throwIO $ Corrupted "ToUnicode: not a stream" []
loadFontDescriptor :: Pdf -> Dict -> IO (Maybe FontDescriptor)
loadFontDescriptor pdf fontDict = do
case HashMap.lookup "FontDescriptor" fontDict of
Nothing -> return Nothing
Just o -> do
ref <- sure $ refValue o
`notice` "FontDescriptor should be a reference"
fd <- (sure . (`notice` "FontDescriptor: not a dictionary") . dictValue) =<<
lookupObject pdf ref
fontName <- required "FontName" nameValue' fd
fontFamily <- optional "FontFamily" stringValue fd
fontStretch <- optional "FontStretch" nameValue' fd
fontWeight <- optional "FontWeight" intValue fd
flags <- required "Flags" int64Value fd
fontBBox <- optional "FontBBox"
(join . fmap (either (const Nothing) Just . rectangleFromArray) . arrayValue) fd
italicAngle <- required "ItalicAngle" realValue fd
ascent <- optional "Ascent" realValue fd
descent <- optional "Descent" realValue fd
leading <- optional "Leading" realValue fd
capHeight <- optional "CapHeight" realValue fd
xHeight <- optional "XHeight" realValue fd
stemV <- optional "StemV" realValue fd
stemH <- optional "StemH" realValue fd
avgWidth <- optional "AvgWidth" realValue fd
maxWidth <- optional "MaxWidth" realValue fd
missingWidth <- optional "MissingWidth" realValue fd
charSet <- optional "CharSet" stringValue fd
return $ Just $ FontDescriptor
{ fdFontName = fontName
, fdFontFamily = fontFamily
, fdFontStretch = fontStretch
, fdFontWeight = fontWeight
, fdFlags = flags
, fdFontBBox = fontBBox
, fdItalicAngle = italicAngle
, fdDescent = descent
, fdAscent = ascent
, fdLeading = leading
, fdCapHeight = capHeight
, fdXHeight = xHeight
, fdStemV = stemV
, fdStemH = stemH
, fdAvgWidth = avgWidth
, fdMaxWidth = maxWidth
, fdMissingWidth = missingWidth
, fdCharSet = charSet
}
where
required = requiredInDict pdf "FontDescriptor"
optional = optionalInDict pdf "FontDescriptor"
nameValue' = fmap Name.toByteString . nameValue
-- | Parse a value from a required field of a dictionary. This will
-- raise an exception if a) the field is not present or b) the field
-- value has a false type.
requiredInDict :: Pdf -- ^ in case the field is a reference
-> String -- ^ a context for a failure notice
-> Name -- ^ name of dictionary field
-> (Object -> Maybe a) -- ^ function for type-casting the object
-> Dict -- ^ the dictionary
-> IO a
requiredInDict pdf context key typeFun dict = do
case HashMap.lookup key dict of
Nothing -> throwIO $ Corrupted (context ++ ": " ++ msg ++ " should exist") []
Just oIn -> do
o <- deref pdf oIn
case typeFun o of
Nothing -> throwIO $ Corrupted (context ++ ": " ++ msg ++ " type failure") []
Just v -> return v
where
msg = Text.unpack $ decodeUtf8With ignore $ Name.toByteString key
-- | Parse a value from an optional field of a dictionary. This will
-- raise an exception if the field value has a false type.
optionalInDict :: Pdf -> String -> Name -> (Object -> Maybe a) -> Dict -> IO (Maybe a)
optionalInDict pdf context key typeFun dict =
case HashMap.lookup key dict of
Nothing -> return Nothing
Just oIn -> do
o <- deref pdf oIn
case typeFun o of
Nothing -> throwIO $ Corrupted (context ++ ": " ++ msg ++ " type failure") []
Just v -> return $ Just v
where
msg = Text.unpack $ decodeUtf8With ignore $ Name.toByteString key