{-# 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 (Int -> FontSubtype -> ShowS
[FontSubtype] -> ShowS
FontSubtype -> String
(Int -> FontSubtype -> ShowS)
-> (FontSubtype -> String)
-> ([FontSubtype] -> ShowS)
-> Show FontSubtype
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FontSubtype] -> ShowS
$cshowList :: [FontSubtype] -> ShowS
show :: FontSubtype -> String
$cshow :: FontSubtype -> String
showsPrec :: Int -> FontSubtype -> ShowS
$cshowsPrec :: Int -> FontSubtype -> ShowS
Show, FontSubtype -> FontSubtype -> Bool
(FontSubtype -> FontSubtype -> Bool)
-> (FontSubtype -> FontSubtype -> Bool) -> Eq FontSubtype
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FontSubtype -> FontSubtype -> Bool
$c/= :: FontSubtype -> FontSubtype -> Bool
== :: FontSubtype -> FontSubtype -> Bool
$c== :: FontSubtype -> FontSubtype -> Bool
Eq)

-- | Get font subtype
fontDictSubtype :: FontDict -> IO FontSubtype
fontDictSubtype :: FontDict -> IO FontSubtype
fontDictSubtype (FontDict Pdf
pdf Dict
dict) = do
  Object
obj <- Either String Object -> IO Object
forall a. Either String a -> IO a
sure (Name -> Dict -> Maybe Object
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Name
"Subtype" Dict
dict
              Maybe Object -> String -> Either String Object
forall a. Maybe a -> String -> Either String a
`notice` String
"Subtype should exist")
            IO Object -> (Object -> IO Object) -> IO Object
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Pdf -> Object -> IO Object
deref Pdf
pdf
  Name
str <- Either String Name -> IO Name
forall a. Either String a -> IO a
sure (Either String Name -> IO Name) -> Either String Name -> IO Name
forall a b. (a -> b) -> a -> b
$ Object -> Maybe Name
nameValue Object
obj Maybe Name -> String -> Either String Name
forall a. Maybe a -> String -> Either String a
`notice` String
"Subtype should be a name"
  case Name
str of
    Name
"Type0" -> FontSubtype -> IO FontSubtype
forall (m :: * -> *) a. Monad m => a -> m a
return FontSubtype
FontType0
    Name
"Type1" -> FontSubtype -> IO FontSubtype
forall (m :: * -> *) a. Monad m => a -> m a
return FontSubtype
FontType1
    Name
"MMType1" -> FontSubtype -> IO FontSubtype
forall (m :: * -> *) a. Monad m => a -> m a
return FontSubtype
FontMMType1
    Name
"Type3" -> FontSubtype -> IO FontSubtype
forall (m :: * -> *) a. Monad m => a -> m a
return FontSubtype
FontType3
    Name
"TrueType" -> FontSubtype -> IO FontSubtype
forall (m :: * -> *) a. Monad m => a -> m a
return FontSubtype
FontTrueType
    Name
_ -> Unexpected -> IO FontSubtype
forall e a. Exception e => e -> IO a
throwIO (Unexpected -> IO FontSubtype) -> Unexpected -> IO FontSubtype
forall a b. (a -> b) -> a -> b
$ String -> [String] -> Unexpected
Unexpected (String
"Unexpected font subtype: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
str) []

-- | Load font info for the font
fontDictLoadInfo :: FontDict -> IO FontInfo
fontDictLoadInfo :: FontDict -> IO FontInfo
fontDictLoadInfo fd :: FontDict
fd@(FontDict Pdf
pdf Dict
fontDict) = do
  FontSubtype
subtype <- FontDict -> IO FontSubtype
fontDictSubtype FontDict
fd
  case FontSubtype
subtype of
    FontSubtype
FontType0 -> FIComposite -> FontInfo
FontInfoComposite (FIComposite -> FontInfo) -> IO FIComposite -> IO FontInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pdf -> Dict -> IO FIComposite
loadFontInfoComposite Pdf
pdf Dict
fontDict
    FontSubtype
FontType3 -> do
      FISimple
fi <- Pdf -> Dict -> IO FISimple
loadFontInfoSimple Pdf
pdf Dict
fontDict
      Object
obj <- Either String Object -> IO Object
forall a. Either String a -> IO a
sure (Name -> Dict -> Maybe Object
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Name
"FontMatrix" Dict
fontDict
                    Maybe Object -> String -> Either String Object
forall a. Maybe a -> String -> Either String a
`notice` String
"FontMatrix should exist")
              IO Object -> (Object -> IO Object) -> IO Object
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Pdf -> Object -> IO Object
deref Pdf
pdf
      Array
arr <- Either String Array -> IO Array
forall a. Either String a -> IO a
sure (Either String Array -> IO Array)
-> Either String Array -> IO Array
forall a b. (a -> b) -> a -> b
$ Object -> Maybe Array
arrayValue Object
obj
                    Maybe Array -> String -> Either String Array
forall a. Maybe a -> String -> Either String a
`notice` String
"FontMatrix should be an array"
      Transform Double
fontMatrix <-
        case (Object -> Maybe Double) -> [Object] -> Maybe [Double]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Object -> Maybe Double
realValue (Array -> [Object]
forall a. Vector a -> [a]
Vector.toList Array
arr) of
          Just [Double
a, Double
b, Double
c, Double
d, Double
e, Double
f] -> do
            Transform Double -> IO (Transform Double)
forall (m :: * -> *) a. Monad m => a -> m a
return (Transform Double -> IO (Transform Double))
-> Transform Double -> IO (Transform Double)
forall a b. (a -> b) -> a -> b
$ Double
-> Double
-> Double
-> Double
-> Double
-> Double
-> Transform Double
forall a. a -> a -> a -> a -> a -> a -> Transform a
Transform Double
a Double
b Double
c Double
d Double
e Double
f
          Maybe [Double]
Nothing -> Corrupted -> IO (Transform Double)
forall e a. Exception e => e -> IO a
throwIO (Corrupted -> IO (Transform Double))
-> Corrupted -> IO (Transform Double)
forall a b. (a -> b) -> a -> b
$ String -> [String] -> Corrupted
Corrupted String
"FontMatrics should contain numbers" []
          Maybe [Double]
_ -> Corrupted -> IO (Transform Double)
forall e a. Exception e => e -> IO a
throwIO (Corrupted -> IO (Transform Double))
-> Corrupted -> IO (Transform Double)
forall a b. (a -> b) -> a -> b
$ String -> [String] -> Corrupted
Corrupted String
"FontMatrix: wrong number of elements" []
      FontInfo -> IO FontInfo
forall (m :: * -> *) a. Monad m => a -> m a
return (FontInfo -> IO FontInfo) -> FontInfo -> IO FontInfo
forall a b. (a -> b) -> a -> b
$ FISimple -> FontInfo
FontInfoSimple FISimple
fi {
        fiSimpleFontMatrix :: Transform Double
fiSimpleFontMatrix = Transform Double
fontMatrix
        }
    FontSubtype
_ -> FISimple -> FontInfo
FontInfoSimple (FISimple -> FontInfo) -> IO FISimple -> IO FontInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pdf -> Dict -> IO FISimple
loadFontInfoSimple Pdf
pdf Dict
fontDict

loadFontInfoComposite :: Pdf -> Dict -> IO FIComposite
loadFontInfoComposite :: Pdf -> Dict -> IO FIComposite
loadFontInfoComposite Pdf
pdf Dict
fontDict = do
  Maybe UnicodeCMap
toUnicode <- Pdf -> Dict -> IO (Maybe UnicodeCMap)
loadUnicodeCMap Pdf
pdf Dict
fontDict

  Dict
descFont <- do
    Object
descFontObj <- Either String Object -> IO Object
forall a. Either String a -> IO a
sure (Name -> Dict -> Maybe Object
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Name
"DescendantFonts" Dict
fontDict
                          Maybe Object -> String -> Either String Object
forall a. Maybe a -> String -> Either String a
`notice` String
"DescendantFonts should exist")
                    IO Object -> (Object -> IO Object) -> IO Object
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Pdf -> Object -> IO Object
deref Pdf
pdf
    Array
descFontArr <- Either String Array -> IO Array
forall a. Either String a -> IO a
sure (Either String Array -> IO Array)
-> Either String Array -> IO Array
forall a b. (a -> b) -> a -> b
$ Object -> Maybe Array
arrayValue Object
descFontObj
        Maybe Array -> String -> Either String Array
forall a. Maybe a -> String -> Either String a
`notice` String
"DescendantFonts should be an array"
    case Array -> [Object]
forall a. Vector a -> [a]
Vector.toList Array
descFontArr of
      [Object
o] -> do
        Object
o' <- Pdf -> Object -> IO Object
deref Pdf
pdf Object
o
        Either String Dict -> IO Dict
forall a. Either String a -> IO a
sure (Either String Dict -> IO Dict) -> Either String Dict -> IO Dict
forall a b. (a -> b) -> a -> b
$ Object -> Maybe Dict
dictValue Object
o'
                Maybe Dict -> String -> Either String Dict
forall a. Maybe a -> String -> Either String a
`notice` String
"DescendantFonts element should be a dictionary"
      [Object]
_ -> Corrupted -> IO Dict
forall e a. Exception e => e -> IO a
throwIO (Corrupted -> IO Dict) -> Corrupted -> IO Dict
forall a b. (a -> b) -> a -> b
$ String -> [String] -> Corrupted
Corrupted
            String
"Unexpected value of DescendantFonts key in font dictionary" []

  Double
defaultWidth <-
    case Name -> Dict -> Maybe Object
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Name
"DW" Dict
descFont of
      Maybe Object
Nothing -> Double -> IO Double
forall (m :: * -> *) a. Monad m => a -> m a
return Double
1000
      Just Object
o -> do
        Object
o' <- Pdf -> Object -> IO Object
deref Pdf
pdf Object
o
        Either String Double -> IO Double
forall a. Either String a -> IO a
sure (Either String Double -> IO Double)
-> Either String Double -> IO Double
forall a b. (a -> b) -> a -> b
$ Object -> Maybe Double
realValue Object
o' Maybe Double -> String -> Either String Double
forall a. Maybe a -> String -> Either String a
`notice` String
"DW should be real"

  CIDFontWidths
widths <-
    case Name -> Dict -> Maybe Object
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Name
"W" Dict
descFont of
      Maybe Object
Nothing -> CIDFontWidths -> IO CIDFontWidths
forall (m :: * -> *) a. Monad m => a -> m a
return CIDFontWidths
forall a. Monoid a => a
mempty
      Just Object
o -> do
        Object
o' <- Pdf -> Object -> IO Object
deref Pdf
pdf Object
o
        Array
arr <- Either String Array -> IO Array
forall a. Either String a -> IO a
sure (Object -> Maybe Array
arrayValue Object
o' Maybe Array -> String -> Either String Array
forall a. Maybe a -> String -> Either String a
`notice` String
"W should be an array")
          IO Array -> (Array -> IO Array) -> IO Array
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Object -> IO Object) -> Array -> IO Array
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Vector a -> m (Vector b)
Vector.mapM (Pdf -> Object -> IO Object
deref Pdf
pdf)
        Either String CIDFontWidths -> IO CIDFontWidths
forall a. Either String a -> IO a
sure (Either String CIDFontWidths -> IO CIDFontWidths)
-> Either String CIDFontWidths -> IO CIDFontWidths
forall a b. (a -> b) -> a -> b
$ Array -> Either String CIDFontWidths
makeCIDFontWidths Array
arr

  Maybe FontDescriptor
fontDescriptor <- Pdf -> Dict -> IO (Maybe FontDescriptor)
loadFontDescriptor Pdf
pdf Dict
descFont

  FIComposite -> IO FIComposite
forall (m :: * -> *) a. Monad m => a -> m a
return (FIComposite -> IO FIComposite) -> FIComposite -> IO FIComposite
forall a b. (a -> b) -> a -> b
$ FIComposite :: Maybe UnicodeCMap
-> CIDFontWidths -> Double -> Maybe FontDescriptor -> FIComposite
FIComposite {
    fiCompositeUnicodeCMap :: Maybe UnicodeCMap
fiCompositeUnicodeCMap = Maybe UnicodeCMap
toUnicode,
    fiCompositeWidths :: CIDFontWidths
fiCompositeWidths = CIDFontWidths
widths,
    fiCompositeDefaultWidth :: Double
fiCompositeDefaultWidth = Double
defaultWidth,
    fiCompositeFontDescriptor :: Maybe FontDescriptor
fiCompositeFontDescriptor = Maybe FontDescriptor
fontDescriptor
    }

loadFontInfoSimple :: Pdf -> Dict -> IO FISimple
loadFontInfoSimple :: Pdf -> Dict -> IO FISimple
loadFontInfoSimple Pdf
pdf Dict
fontDict = do
  Maybe UnicodeCMap
toUnicode <- Pdf -> Dict -> IO (Maybe UnicodeCMap)
loadUnicodeCMap Pdf
pdf Dict
fontDict

  Maybe SimpleFontEncoding
encoding <-
    case Name -> Dict -> Maybe Object
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Name
"Encoding" Dict
fontDict of
      Just (Name Name
"WinAnsiEncoding") -> Maybe SimpleFontEncoding -> IO (Maybe SimpleFontEncoding)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe SimpleFontEncoding -> IO (Maybe SimpleFontEncoding))
-> Maybe SimpleFontEncoding -> IO (Maybe SimpleFontEncoding)
forall a b. (a -> b) -> a -> b
$ SimpleFontEncoding -> Maybe SimpleFontEncoding
forall a. a -> Maybe a
Just SimpleFontEncoding :: FontBaseEncoding -> [(Word8, ByteString)] -> SimpleFontEncoding
SimpleFontEncoding
        { simpleFontBaseEncoding :: FontBaseEncoding
simpleFontBaseEncoding = FontBaseEncoding
FontBaseEncodingWinAnsi
        , simpleFontDifferences :: [(Word8, ByteString)]
simpleFontDifferences = []
        }
      Just (Name Name
"MacRomanEncoding") -> Maybe SimpleFontEncoding -> IO (Maybe SimpleFontEncoding)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe SimpleFontEncoding -> IO (Maybe SimpleFontEncoding))
-> Maybe SimpleFontEncoding -> IO (Maybe SimpleFontEncoding)
forall a b. (a -> b) -> a -> b
$ SimpleFontEncoding -> Maybe SimpleFontEncoding
forall a. a -> Maybe a
Just SimpleFontEncoding :: FontBaseEncoding -> [(Word8, ByteString)] -> SimpleFontEncoding
SimpleFontEncoding
        { simpleFontBaseEncoding :: FontBaseEncoding
simpleFontBaseEncoding = FontBaseEncoding
FontBaseEncodingMacRoman
        , simpleFontDifferences :: [(Word8, ByteString)]
simpleFontDifferences = []
        }
      Just Object
o -> do
        Object
o' <- Pdf -> Object -> IO Object
deref Pdf
pdf Object
o
        Dict
encDict <- Either String Dict -> IO Dict
forall a. Either String a -> IO a
sure (Object -> Maybe Dict
dictValue Object
o'
                      Maybe Dict -> String -> Either String Dict
forall a. Maybe a -> String -> Either String a
`notice` String
"Encoding should be a dictionary")
        case Name -> Dict -> Maybe Object
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Name
"BaseEncoding" Dict
encDict of
          Just (Name Name
"WinAnsiEncoding") -> do
            [(Word8, ByteString)]
diffs <- Pdf -> Dict -> IO [(Word8, ByteString)]
loadEncodingDifferences Pdf
pdf Dict
encDict
            Maybe SimpleFontEncoding -> IO (Maybe SimpleFontEncoding)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe SimpleFontEncoding -> IO (Maybe SimpleFontEncoding))
-> Maybe SimpleFontEncoding -> IO (Maybe SimpleFontEncoding)
forall a b. (a -> b) -> a -> b
$ SimpleFontEncoding -> Maybe SimpleFontEncoding
forall a. a -> Maybe a
Just SimpleFontEncoding :: FontBaseEncoding -> [(Word8, ByteString)] -> SimpleFontEncoding
SimpleFontEncoding
              { simpleFontBaseEncoding :: FontBaseEncoding
simpleFontBaseEncoding = FontBaseEncoding
FontBaseEncodingWinAnsi
              , simpleFontDifferences :: [(Word8, ByteString)]
simpleFontDifferences = [(Word8, ByteString)]
diffs
              }
          Just (Name Name
"MacRomanEncoding") -> do
            [(Word8, ByteString)]
diffs <- Pdf -> Dict -> IO [(Word8, ByteString)]
loadEncodingDifferences Pdf
pdf Dict
encDict
            Maybe SimpleFontEncoding -> IO (Maybe SimpleFontEncoding)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe SimpleFontEncoding -> IO (Maybe SimpleFontEncoding))
-> Maybe SimpleFontEncoding -> IO (Maybe SimpleFontEncoding)
forall a b. (a -> b) -> a -> b
$ SimpleFontEncoding -> Maybe SimpleFontEncoding
forall a. a -> Maybe a
Just SimpleFontEncoding :: FontBaseEncoding -> [(Word8, ByteString)] -> SimpleFontEncoding
SimpleFontEncoding
              { simpleFontBaseEncoding :: FontBaseEncoding
simpleFontBaseEncoding = FontBaseEncoding
FontBaseEncodingMacRoman
              , simpleFontDifferences :: [(Word8, ByteString)]
simpleFontDifferences = [(Word8, ByteString)]
diffs
              }
          Maybe Object
Nothing -> do
            [(Word8, ByteString)]
diffs <- Pdf -> Dict -> IO [(Word8, ByteString)]
loadEncodingDifferences Pdf
pdf Dict
encDict
            Maybe SimpleFontEncoding -> IO (Maybe SimpleFontEncoding)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe SimpleFontEncoding -> IO (Maybe SimpleFontEncoding))
-> Maybe SimpleFontEncoding -> IO (Maybe SimpleFontEncoding)
forall a b. (a -> b) -> a -> b
$ SimpleFontEncoding -> Maybe SimpleFontEncoding
forall a. a -> Maybe a
Just SimpleFontEncoding :: FontBaseEncoding -> [(Word8, ByteString)] -> SimpleFontEncoding
SimpleFontEncoding
              -- XXX: should be StandardEncoding?
              { simpleFontBaseEncoding :: FontBaseEncoding
simpleFontBaseEncoding = FontBaseEncoding
FontBaseEncodingWinAnsi
              , simpleFontDifferences :: [(Word8, ByteString)]
simpleFontDifferences = [(Word8, ByteString)]
diffs
              }
          Maybe Object
_ -> Maybe SimpleFontEncoding -> IO (Maybe SimpleFontEncoding)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SimpleFontEncoding
forall a. Maybe a
Nothing
      Maybe Object
_ -> Maybe SimpleFontEncoding -> IO (Maybe SimpleFontEncoding)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SimpleFontEncoding
forall a. Maybe a
Nothing

  Maybe (Int, Int, [Double])
widths <-
    case Name -> Dict -> Maybe Object
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Name
"Widths" Dict
fontDict of
      Maybe Object
Nothing -> Maybe (Int, Int, [Double]) -> IO (Maybe (Int, Int, [Double]))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Int, Int, [Double])
forall a. Maybe a
Nothing
      Just Object
v -> do
        Object
v' <- Pdf -> Object -> IO Object
deref Pdf
pdf Object
v
        Array
array <- Either String Array -> IO Array
forall a. Either String a -> IO a
sure (Either String Array -> IO Array)
-> Either String Array -> IO Array
forall a b. (a -> b) -> a -> b
$ Object -> Maybe Array
arrayValue Object
v'
            Maybe Array -> String -> Either String Array
forall a. Maybe a -> String -> Either String a
`notice` String
"Widths should be an array"
        [Double]
widths <- [Object] -> (Object -> IO Double) -> IO [Double]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Array -> [Object]
forall a. Vector a -> [a]
Vector.toList Array
array) ((Object -> IO Double) -> IO [Double])
-> (Object -> IO Double) -> IO [Double]
forall a b. (a -> b) -> a -> b
$ \Object
o ->
          Either String Double -> IO Double
forall a. Either String a -> IO a
sure (Object -> Maybe Double
realValue Object
o Maybe Double -> String -> Either String Double
forall a. Maybe a -> String -> Either String a
`notice` String
"Widths elements should be real")
        Int
firstChar <- Either String Int -> IO Int
forall a. Either String a -> IO a
sure (Either String Int -> IO Int) -> Either String Int -> IO Int
forall a b. (a -> b) -> a -> b
$ (Name -> Dict -> Maybe Object
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Name
"FirstChar" Dict
fontDict Maybe Object -> (Object -> Maybe Int) -> Maybe Int
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Object -> Maybe Int
intValue)
                Maybe Int -> String -> Either String Int
forall a. Maybe a -> String -> Either String a
`notice` String
"FirstChar should be an integer"
        Int
lastChar <- Either String Int -> IO Int
forall a. Either String a -> IO a
sure (Either String Int -> IO Int) -> Either String Int -> IO Int
forall a b. (a -> b) -> a -> b
$ (Name -> Dict -> Maybe Object
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Name
"LastChar" Dict
fontDict Maybe Object -> (Object -> Maybe Int) -> Maybe Int
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Object -> Maybe Int
intValue)
                Maybe Int -> String -> Either String Int
forall a. Maybe a -> String -> Either String a
`notice` String
"LastChar should be an integer"
        Maybe (Int, Int, [Double]) -> IO (Maybe (Int, Int, [Double]))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Int, Int, [Double]) -> IO (Maybe (Int, Int, [Double])))
-> Maybe (Int, Int, [Double]) -> IO (Maybe (Int, Int, [Double]))
forall a b. (a -> b) -> a -> b
$ (Int, Int, [Double]) -> Maybe (Int, Int, [Double])
forall a. a -> Maybe a
Just (Int
firstChar, Int
lastChar, [Double]
widths)

  Maybe FontDescriptor
fontDescriptor <- Pdf -> Dict -> IO (Maybe FontDescriptor)
loadFontDescriptor Pdf
pdf Dict
fontDict

  FISimple -> IO FISimple
forall (m :: * -> *) a. Monad m => a -> m a
return (FISimple -> IO FISimple) -> FISimple -> IO FISimple
forall a b. (a -> b) -> a -> b
$ FISimple :: Maybe UnicodeCMap
-> Maybe SimpleFontEncoding
-> Maybe (Int, Int, [Double])
-> Transform Double
-> Maybe FontDescriptor
-> FISimple
FISimple
    { fiSimpleUnicodeCMap :: Maybe UnicodeCMap
fiSimpleUnicodeCMap = Maybe UnicodeCMap
toUnicode
    , fiSimpleEncoding :: Maybe SimpleFontEncoding
fiSimpleEncoding = Maybe SimpleFontEncoding
encoding
    , fiSimpleWidths :: Maybe (Int, Int, [Double])
fiSimpleWidths = Maybe (Int, Int, [Double])
widths
    , fiSimpleFontMatrix :: Transform Double
fiSimpleFontMatrix = Double -> Double -> Transform Double
forall a. Num a => a -> a -> Transform a
scale Double
0.001 Double
0.001
    , fiSimpleFontDescriptor :: Maybe FontDescriptor
fiSimpleFontDescriptor = Maybe FontDescriptor
fontDescriptor
    }

loadEncodingDifferences :: Pdf -> Dict -> IO [(Word8, ByteString)]
loadEncodingDifferences :: Pdf -> Dict -> IO [(Word8, ByteString)]
loadEncodingDifferences Pdf
pdf Dict
dict = do
  case Name -> Dict -> Maybe Object
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Name
"Differences" Dict
dict of
    Maybe Object
Nothing -> [(Word8, ByteString)] -> IO [(Word8, ByteString)]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    Just Object
v -> do
      Object
v' <- Pdf -> Object -> IO Object
deref Pdf
pdf Object
v
      Array
arr <- Either String Array -> IO Array
forall a. Either String a -> IO a
sure (Either String Array -> IO Array)
-> Either String Array -> IO Array
forall a b. (a -> b) -> a -> b
$ Object -> Maybe Array
arrayValue Object
v'
          Maybe Array -> String -> Either String Array
forall a. Maybe a -> String -> Either String a
`notice` String
"Differences should be an array"
      case Array -> [Object]
forall a. Vector a -> [a]
Vector.toList Array
arr of
        [] -> [(Word8, ByteString)] -> IO [(Word8, ByteString)]
forall (m :: * -> *) a. Monad m => a -> m a
return []
        (Object
o : [Object]
rest) -> do
          Word8
n' <- Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> IO Int -> IO Word8
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Either String Int -> IO Int
forall a. Either String a -> IO a
sure (Either String Int -> IO Int) -> Either String Int -> IO Int
forall a b. (a -> b) -> a -> b
$ Object -> Maybe Int
intValue Object
o
                  Maybe Int -> String -> Either String Int
forall a. Maybe a -> String -> Either String a
`notice` String
"Differences: the first element should be integer")
          [(Word8, ByteString)]
-> Word8 -> [Object] -> IO [(Word8, ByteString)]
forall t.
Num t =>
[(t, ByteString)] -> t -> [Object] -> IO [(t, ByteString)]
go [] Word8
n' [Object]
rest
  where
  go :: [(t, ByteString)] -> t -> [Object] -> IO [(t, ByteString)]
go [(t, ByteString)]
res t
_ [] = [(t, ByteString)] -> IO [(t, ByteString)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(t, ByteString)]
res
  go [(t, ByteString)]
res t
n (Object
o:[Object]
rest) =
    case Object
o of
      (Number Scientific
_) -> do
        t
n' <- Int -> t
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> t) -> IO Int -> IO t
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Either String Int -> IO Int
forall a. Either String a -> IO a
sure (Either String Int -> IO Int) -> Either String Int -> IO Int
forall a b. (a -> b) -> a -> b
$ Object -> Maybe Int
intValue Object
o
          Maybe Int -> String -> Either String Int
forall a. Maybe a -> String -> Either String a
`notice` String
"Differences: elements should be integers")
        [(t, ByteString)] -> t -> [Object] -> IO [(t, ByteString)]
go [(t, ByteString)]
res t
n' [Object]
rest
      (Name Name
name) -> [(t, ByteString)] -> t -> [Object] -> IO [(t, ByteString)]
go (((t
n, Name -> ByteString
Name.toByteString Name
name)) (t, ByteString) -> [(t, ByteString)] -> [(t, ByteString)]
forall a. a -> [a] -> [a]
: [(t, ByteString)]
res) (t
n t -> t -> t
forall a. Num a => a -> a -> a
+ t
1) [Object]
rest
      Object
_ -> Corrupted -> IO [(t, ByteString)]
forall e a. Exception e => e -> IO a
throwIO (Corrupted -> IO [(t, ByteString)])
-> Corrupted -> IO [(t, ByteString)]
forall a b. (a -> b) -> a -> b
$ String -> [String] -> Corrupted
Corrupted
        (String
"Differences array: unexpected object: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Object -> String
forall a. Show a => a -> String
show Object
o) []

loadUnicodeCMap :: Pdf -> Dict -> IO (Maybe UnicodeCMap)
loadUnicodeCMap :: Pdf -> Dict -> IO (Maybe UnicodeCMap)
loadUnicodeCMap Pdf
pdf Dict
fontDict =
  case Name -> Dict -> Maybe Object
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Name
"ToUnicode" Dict
fontDict of
    Maybe Object
Nothing -> Maybe UnicodeCMap -> IO (Maybe UnicodeCMap)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe UnicodeCMap
forall a. Maybe a
Nothing
    Just Object
o -> do
      Ref
ref <- Either String Ref -> IO Ref
forall a. Either String a -> IO a
sure (Either String Ref -> IO Ref) -> Either String Ref -> IO Ref
forall a b. (a -> b) -> a -> b
$ Object -> Maybe Ref
refValue Object
o
        Maybe Ref -> String -> Either String Ref
forall a. Maybe a -> String -> Either String a
`notice` String
"ToUnicode should be a reference"
      Object
toUnicode <- Pdf -> Ref -> IO Object
lookupObject Pdf
pdf Ref
ref
      case Object
toUnicode of
        Stream Stream
s -> do
          InputStream ByteString
is <- Pdf -> Ref -> Stream -> IO (InputStream ByteString)
streamContent Pdf
pdf Ref
ref Stream
s
          ByteString
content <- [ByteString] -> ByteString
forall a. Monoid a => [a] -> a
mconcat ([ByteString] -> ByteString) -> IO [ByteString] -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> InputStream ByteString -> IO [ByteString]
forall a. InputStream a -> IO [a]
Streams.toList InputStream ByteString
is
          case ByteString -> Either String UnicodeCMap
parseUnicodeCMap ByteString
content of
            Left String
e -> Corrupted -> IO (Maybe UnicodeCMap)
forall e a. Exception e => e -> IO a
throwIO (Corrupted -> IO (Maybe UnicodeCMap))
-> Corrupted -> IO (Maybe UnicodeCMap)
forall a b. (a -> b) -> a -> b
$ String -> [String] -> Corrupted
Corrupted (String
"can't parse cmap: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
e) []
            Right UnicodeCMap
cmap -> Maybe UnicodeCMap -> IO (Maybe UnicodeCMap)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe UnicodeCMap -> IO (Maybe UnicodeCMap))
-> Maybe UnicodeCMap -> IO (Maybe UnicodeCMap)
forall a b. (a -> b) -> a -> b
$ UnicodeCMap -> Maybe UnicodeCMap
forall a. a -> Maybe a
Just UnicodeCMap
cmap
        Object
_ -> Corrupted -> IO (Maybe UnicodeCMap)
forall e a. Exception e => e -> IO a
throwIO (Corrupted -> IO (Maybe UnicodeCMap))
-> Corrupted -> IO (Maybe UnicodeCMap)
forall a b. (a -> b) -> a -> b
$ String -> [String] -> Corrupted
Corrupted String
"ToUnicode: not a stream" []


loadFontDescriptor :: Pdf -> Dict -> IO (Maybe FontDescriptor)
loadFontDescriptor :: Pdf -> Dict -> IO (Maybe FontDescriptor)
loadFontDescriptor Pdf
pdf Dict
fontDict = do
  case Name -> Dict -> Maybe Object
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Name
"FontDescriptor" Dict
fontDict of
    Maybe Object
Nothing -> Maybe FontDescriptor -> IO (Maybe FontDescriptor)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe FontDescriptor
forall a. Maybe a
Nothing
    Just Object
o -> do
      Ref
ref <- Either String Ref -> IO Ref
forall a. Either String a -> IO a
sure (Either String Ref -> IO Ref) -> Either String Ref -> IO Ref
forall a b. (a -> b) -> a -> b
$ Object -> Maybe Ref
refValue Object
o
             Maybe Ref -> String -> Either String Ref
forall a. Maybe a -> String -> Either String a
`notice` String
"FontDescriptor should be a reference"
      Dict
fd <- (Either String Dict -> IO Dict
forall a. Either String a -> IO a
sure (Either String Dict -> IO Dict)
-> (Object -> Either String Dict) -> Object -> IO Dict
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Dict -> String -> Either String Dict
forall a. Maybe a -> String -> Either String a
`notice` String
"FontDescriptor: not a dictionary") (Maybe Dict -> Either String Dict)
-> (Object -> Maybe Dict) -> Object -> Either String Dict
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Object -> Maybe Dict
dictValue) (Object -> IO Dict) -> IO Object -> IO Dict
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
            Pdf -> Ref -> IO Object
lookupObject Pdf
pdf Ref
ref

      ByteString
fontName <- Name -> (Object -> Maybe ByteString) -> Dict -> IO ByteString
forall a. Name -> (Object -> Maybe a) -> Dict -> IO a
required Name
"FontName" Object -> Maybe ByteString
nameValue' Dict
fd
      Maybe ByteString
fontFamily <- Name
-> (Object -> Maybe ByteString) -> Dict -> IO (Maybe ByteString)
forall a. Name -> (Object -> Maybe a) -> Dict -> IO (Maybe a)
optional Name
"FontFamily" Object -> Maybe ByteString
stringValue Dict
fd
      Maybe ByteString
fontStretch <- Name
-> (Object -> Maybe ByteString) -> Dict -> IO (Maybe ByteString)
forall a. Name -> (Object -> Maybe a) -> Dict -> IO (Maybe a)
optional Name
"FontStretch" Object -> Maybe ByteString
nameValue' Dict
fd
      Maybe Int
fontWeight <- Name -> (Object -> Maybe Int) -> Dict -> IO (Maybe Int)
forall a. Name -> (Object -> Maybe a) -> Dict -> IO (Maybe a)
optional Name
"FontWeight" Object -> Maybe Int
intValue Dict
fd
      Int64
flags <- Name -> (Object -> Maybe Int64) -> Dict -> IO Int64
forall a. Name -> (Object -> Maybe a) -> Dict -> IO a
required Name
"Flags" Object -> Maybe Int64
int64Value Dict
fd
      Maybe (Rectangle Double)
fontBBox <- Name
-> (Object -> Maybe (Rectangle Double))
-> Dict
-> IO (Maybe (Rectangle Double))
forall a. Name -> (Object -> Maybe a) -> Dict -> IO (Maybe a)
optional Name
"FontBBox"
        (Maybe (Maybe (Rectangle Double)) -> Maybe (Rectangle Double)
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Maybe (Maybe (Rectangle Double)) -> Maybe (Rectangle Double))
-> (Object -> Maybe (Maybe (Rectangle Double)))
-> Object
-> Maybe (Rectangle Double)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Array -> Maybe (Rectangle Double))
-> Maybe Array -> Maybe (Maybe (Rectangle Double))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((String -> Maybe (Rectangle Double))
-> (Rectangle Double -> Maybe (Rectangle Double))
-> Either String (Rectangle Double)
-> Maybe (Rectangle Double)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe (Rectangle Double) -> String -> Maybe (Rectangle Double)
forall a b. a -> b -> a
const Maybe (Rectangle Double)
forall a. Maybe a
Nothing) Rectangle Double -> Maybe (Rectangle Double)
forall a. a -> Maybe a
Just (Either String (Rectangle Double) -> Maybe (Rectangle Double))
-> (Array -> Either String (Rectangle Double))
-> Array
-> Maybe (Rectangle Double)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Array -> Either String (Rectangle Double)
rectangleFromArray) (Maybe Array -> Maybe (Maybe (Rectangle Double)))
-> (Object -> Maybe Array)
-> Object
-> Maybe (Maybe (Rectangle Double))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Object -> Maybe Array
arrayValue) Dict
fd
      Double
italicAngle <- Name -> (Object -> Maybe Double) -> Dict -> IO Double
forall a. Name -> (Object -> Maybe a) -> Dict -> IO a
required Name
"ItalicAngle" Object -> Maybe Double
realValue Dict
fd
      Maybe Double
ascent <- Name -> (Object -> Maybe Double) -> Dict -> IO (Maybe Double)
forall a. Name -> (Object -> Maybe a) -> Dict -> IO (Maybe a)
optional Name
"Ascent" Object -> Maybe Double
realValue Dict
fd
      Maybe Double
descent <- Name -> (Object -> Maybe Double) -> Dict -> IO (Maybe Double)
forall a. Name -> (Object -> Maybe a) -> Dict -> IO (Maybe a)
optional Name
"Descent" Object -> Maybe Double
realValue Dict
fd
      Maybe Double
leading <- Name -> (Object -> Maybe Double) -> Dict -> IO (Maybe Double)
forall a. Name -> (Object -> Maybe a) -> Dict -> IO (Maybe a)
optional Name
"Leading" Object -> Maybe Double
realValue Dict
fd
      Maybe Double
capHeight <- Name -> (Object -> Maybe Double) -> Dict -> IO (Maybe Double)
forall a. Name -> (Object -> Maybe a) -> Dict -> IO (Maybe a)
optional Name
"CapHeight" Object -> Maybe Double
realValue Dict
fd
      Maybe Double
xHeight <- Name -> (Object -> Maybe Double) -> Dict -> IO (Maybe Double)
forall a. Name -> (Object -> Maybe a) -> Dict -> IO (Maybe a)
optional Name
"XHeight" Object -> Maybe Double
realValue Dict
fd
      Maybe Double
stemV <- Name -> (Object -> Maybe Double) -> Dict -> IO (Maybe Double)
forall a. Name -> (Object -> Maybe a) -> Dict -> IO (Maybe a)
optional Name
"StemV" Object -> Maybe Double
realValue Dict
fd
      Maybe Double
stemH <- Name -> (Object -> Maybe Double) -> Dict -> IO (Maybe Double)
forall a. Name -> (Object -> Maybe a) -> Dict -> IO (Maybe a)
optional Name
"StemH" Object -> Maybe Double
realValue Dict
fd
      Maybe Double
avgWidth <- Name -> (Object -> Maybe Double) -> Dict -> IO (Maybe Double)
forall a. Name -> (Object -> Maybe a) -> Dict -> IO (Maybe a)
optional Name
"AvgWidth" Object -> Maybe Double
realValue Dict
fd
      Maybe Double
maxWidth <- Name -> (Object -> Maybe Double) -> Dict -> IO (Maybe Double)
forall a. Name -> (Object -> Maybe a) -> Dict -> IO (Maybe a)
optional Name
"MaxWidth" Object -> Maybe Double
realValue Dict
fd
      Maybe Double
missingWidth <- Name -> (Object -> Maybe Double) -> Dict -> IO (Maybe Double)
forall a. Name -> (Object -> Maybe a) -> Dict -> IO (Maybe a)
optional Name
"MissingWidth" Object -> Maybe Double
realValue Dict
fd
      Maybe ByteString
charSet <- Name
-> (Object -> Maybe ByteString) -> Dict -> IO (Maybe ByteString)
forall a. Name -> (Object -> Maybe a) -> Dict -> IO (Maybe a)
optional Name
"CharSet" Object -> Maybe ByteString
stringValue Dict
fd

      Maybe FontDescriptor -> IO (Maybe FontDescriptor)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe FontDescriptor -> IO (Maybe FontDescriptor))
-> Maybe FontDescriptor -> IO (Maybe FontDescriptor)
forall a b. (a -> b) -> a -> b
$ FontDescriptor -> Maybe FontDescriptor
forall a. a -> Maybe a
Just (FontDescriptor -> Maybe FontDescriptor)
-> FontDescriptor -> Maybe FontDescriptor
forall a b. (a -> b) -> a -> b
$ FontDescriptor :: ByteString
-> Maybe ByteString
-> Maybe ByteString
-> Maybe Int
-> Int64
-> Maybe (Rectangle Double)
-> Double
-> Maybe Double
-> Maybe Double
-> Maybe Double
-> Maybe Double
-> Maybe Double
-> Maybe Double
-> Maybe Double
-> Maybe Double
-> Maybe Double
-> Maybe Double
-> Maybe ByteString
-> FontDescriptor
FontDescriptor
        { fdFontName :: ByteString
fdFontName = ByteString
fontName
        , fdFontFamily :: Maybe ByteString
fdFontFamily = Maybe ByteString
fontFamily
        , fdFontStretch :: Maybe ByteString
fdFontStretch = Maybe ByteString
fontStretch
        , fdFontWeight :: Maybe Int
fdFontWeight = Maybe Int
fontWeight
        , fdFlags :: Int64
fdFlags = Int64
flags
        , fdFontBBox :: Maybe (Rectangle Double)
fdFontBBox = Maybe (Rectangle Double)
fontBBox
        , fdItalicAngle :: Double
fdItalicAngle = Double
italicAngle
        , fdDescent :: Maybe Double
fdDescent = Maybe Double
descent
        , fdAscent :: Maybe Double
fdAscent = Maybe Double
ascent
        , fdLeading :: Maybe Double
fdLeading = Maybe Double
leading
        , fdCapHeight :: Maybe Double
fdCapHeight = Maybe Double
capHeight
        , fdXHeight :: Maybe Double
fdXHeight = Maybe Double
xHeight
        , fdStemV :: Maybe Double
fdStemV = Maybe Double
stemV
        , fdStemH :: Maybe Double
fdStemH = Maybe Double
stemH
        , fdAvgWidth :: Maybe Double
fdAvgWidth = Maybe Double
avgWidth
        , fdMaxWidth :: Maybe Double
fdMaxWidth = Maybe Double
maxWidth
        , fdMissingWidth :: Maybe Double
fdMissingWidth = Maybe Double
missingWidth
        , fdCharSet :: Maybe ByteString
fdCharSet = Maybe ByteString
charSet
        }
  where
    required :: Name -> (Object -> Maybe a) -> Dict -> IO a
required = String -> Name -> (Object -> Maybe a) -> Dict -> IO a
forall a. String -> Name -> (Object -> Maybe a) -> Dict -> IO a
requiredInDict String
"FontDescriptor"
    optional :: Name -> (Object -> Maybe a) -> Dict -> IO (Maybe a)
optional = String -> Name -> (Object -> Maybe a) -> Dict -> IO (Maybe a)
forall a.
String -> Name -> (Object -> Maybe a) -> Dict -> IO (Maybe a)
optionalInDict String
"FontDescriptor"
    nameValue' :: Object -> Maybe ByteString
nameValue' = (Name -> ByteString) -> Maybe Name -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> ByteString
Name.toByteString (Maybe Name -> Maybe ByteString)
-> (Object -> Maybe Name) -> Object -> Maybe ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Object -> Maybe Name
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 :: 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 :: String -> Name -> (Object -> Maybe a) -> Dict -> IO a
requiredInDict String
context Name
key Object -> Maybe a
typeFun =
  IO (IO a) -> IO a
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO a) -> IO a) -> (Dict -> IO (IO a)) -> Dict -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Either String (IO a) -> IO (IO a)
forall a. Either String a -> IO a
sure (Either String (IO a) -> IO (IO a))
-> (Dict -> Either String (IO a)) -> Dict -> IO (IO a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe (IO a) -> String -> Either String (IO a)
forall a. Maybe a -> String -> Either String a
`notice` (String
context String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
msg String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" should exist")) (Maybe (IO a) -> Either String (IO a))
-> (Dict -> Maybe (IO a)) -> Dict -> Either String (IO a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  (Object -> IO a) -> Maybe Object -> Maybe (IO a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Either String a -> IO a
forall a. Either String a -> IO a
sure (Either String a -> IO a)
-> (Object -> Either String a) -> Object -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe a -> String -> Either String a
forall a. Maybe a -> String -> Either String a
`notice` (String
context String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
msg String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" type failure")) (Maybe a -> Either String a)
-> (Object -> Maybe a) -> Object -> Either String a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Object -> Maybe a
typeFun) (Maybe Object -> Maybe (IO a))
-> (Dict -> Maybe Object) -> Dict -> Maybe (IO a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Name -> Dict -> Maybe Object
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Name
key
  where
    msg :: String
msg = Text -> String
Text.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
forall a b. OnError a b
ignore (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ Name -> ByteString
Name.toByteString Name
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 :: String -> Name -> (Object -> Maybe a) -> Dict -> IO (Maybe a)
optionalInDict :: String -> Name -> (Object -> Maybe a) -> Dict -> IO (Maybe a)
optionalInDict String
context Name
key Object -> Maybe a
typeFun =
  IO (Maybe a)
-> (IO a -> IO (Maybe a)) -> Maybe (IO a) -> IO (Maybe a)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing) ((a -> Maybe a) -> IO a -> IO (Maybe a)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM a -> Maybe a
forall a. a -> Maybe a
Just) (Maybe (IO a) -> IO (Maybe a))
-> (Dict -> Maybe (IO a)) -> Dict -> IO (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  (Object -> IO a) -> Maybe Object -> Maybe (IO a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Either String a -> IO a
forall a. Either String a -> IO a
sure (Either String a -> IO a)
-> (Object -> Either String a) -> Object -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe a -> String -> Either String a
forall a. Maybe a -> String -> Either String a
`notice` (String
context String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
msg String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" type failure")) (Maybe a -> Either String a)
-> (Object -> Maybe a) -> Object -> Either String a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Object -> Maybe a
typeFun) (Maybe Object -> Maybe (IO a))
-> (Dict -> Maybe Object) -> Dict -> Maybe (IO a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Name -> Dict -> Maybe Object
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Name
key
  where
    msg :: String
msg = Text -> String
Text.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
forall a b. OnError a b
ignore (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ Name -> ByteString
Name.toByteString Name
key