-- | Font info contains information, extracted from font,
-- that may be needed when processing content stream

module Pdf.Content.FontInfo
(
  FontInfo(..),
  FISimple(..),
  FontBaseEncoding(..),
  SimpleFontEncoding(..),
  FIComposite(..),
  CIDFontWidths(..),
  makeCIDFontWidths,
  cidFontGetWidth,
  fontInfoDecodeGlyphs
)
where

import Pdf.Core
import Pdf.Core.Util
import Pdf.Core.Object.Util
import Pdf.Core.Types

import Pdf.Content.UnicodeCMap
import Pdf.Content.Transform
import Pdf.Content.Processor (Glyph(..))
import Pdf.Content.GlyphList
import Pdf.Content.TexGlyphList
import Pdf.Content.FontDescriptor
import qualified Pdf.Content.Encoding.WinAnsi as WinAnsi
import qualified Pdf.Content.Encoding.MacRoman as MacRoman

import Data.List
import Data.Maybe
import Data.Word
import Data.Map (Map)
import qualified Data.Map as Map
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import qualified Data.Vector as Vector
import Control.Monad

-- | Font info
data FontInfo
  = FontInfoSimple FISimple
  | FontInfoComposite FIComposite
  deriving (Int -> FontInfo -> ShowS
[FontInfo] -> ShowS
FontInfo -> String
(Int -> FontInfo -> ShowS)
-> (FontInfo -> String) -> ([FontInfo] -> ShowS) -> Show FontInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FontInfo] -> ShowS
$cshowList :: [FontInfo] -> ShowS
show :: FontInfo -> String
$cshow :: FontInfo -> String
showsPrec :: Int -> FontInfo -> ShowS
$cshowsPrec :: Int -> FontInfo -> ShowS
Show)

-- | Font info for simple fonts
data FISimple = FISimple {
  FISimple -> Maybe UnicodeCMap
fiSimpleUnicodeCMap :: Maybe UnicodeCMap,
  FISimple -> Maybe SimpleFontEncoding
fiSimpleEncoding :: Maybe SimpleFontEncoding,
  FISimple -> Maybe (Int, Int, [Double])
fiSimpleWidths :: Maybe (Int, Int, [Double]),
  -- ^ FirstChar, LastChar, list of widths
  FISimple -> Transform Double
fiSimpleFontMatrix :: Transform Double,
  -- FIXME: no Maybe as soon as this library provides metrics for the
  -- 14 standard fonts
  FISimple -> Maybe FontDescriptor
fiSimpleFontDescriptor :: Maybe FontDescriptor
  }
  deriving (Int -> FISimple -> ShowS
[FISimple] -> ShowS
FISimple -> String
(Int -> FISimple -> ShowS)
-> (FISimple -> String) -> ([FISimple] -> ShowS) -> Show FISimple
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FISimple] -> ShowS
$cshowList :: [FISimple] -> ShowS
show :: FISimple -> String
$cshow :: FISimple -> String
showsPrec :: Int -> FISimple -> ShowS
$cshowsPrec :: Int -> FISimple -> ShowS
Show)

-- | Standard encoding, other encodings are based on them
data FontBaseEncoding
  = FontBaseEncodingWinAnsi
  | FontBaseEncodingMacRoman
  deriving (Int -> FontBaseEncoding -> ShowS
[FontBaseEncoding] -> ShowS
FontBaseEncoding -> String
(Int -> FontBaseEncoding -> ShowS)
-> (FontBaseEncoding -> String)
-> ([FontBaseEncoding] -> ShowS)
-> Show FontBaseEncoding
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FontBaseEncoding] -> ShowS
$cshowList :: [FontBaseEncoding] -> ShowS
show :: FontBaseEncoding -> String
$cshow :: FontBaseEncoding -> String
showsPrec :: Int -> FontBaseEncoding -> ShowS
$cshowsPrec :: Int -> FontBaseEncoding -> ShowS
Show)

-- | Encoding fo simple font
data SimpleFontEncoding = SimpleFontEncoding {
  SimpleFontEncoding -> FontBaseEncoding
simpleFontBaseEncoding :: FontBaseEncoding,
  -- | Mapping from glyph code to glyph name for cases when it is different
  -- from base encoding
  SimpleFontEncoding -> [(Word8, ByteString)]
simpleFontDifferences :: [(Word8, ByteString)]
  }
  deriving (Int -> SimpleFontEncoding -> ShowS
[SimpleFontEncoding] -> ShowS
SimpleFontEncoding -> String
(Int -> SimpleFontEncoding -> ShowS)
-> (SimpleFontEncoding -> String)
-> ([SimpleFontEncoding] -> ShowS)
-> Show SimpleFontEncoding
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SimpleFontEncoding] -> ShowS
$cshowList :: [SimpleFontEncoding] -> ShowS
show :: SimpleFontEncoding -> String
$cshow :: SimpleFontEncoding -> String
showsPrec :: Int -> SimpleFontEncoding -> ShowS
$cshowsPrec :: Int -> SimpleFontEncoding -> ShowS
Show)

-- | Font info for Type0 font
data FIComposite = FIComposite {
  FIComposite -> Maybe UnicodeCMap
fiCompositeUnicodeCMap :: Maybe UnicodeCMap,
  FIComposite -> CIDFontWidths
fiCompositeWidths :: CIDFontWidths,
  FIComposite -> Double
fiCompositeDefaultWidth :: Double,
  -- FontDescriptor is present in CIDFonts, but according to specs
  -- shall not be used with Type0 fonts
  FIComposite -> Maybe FontDescriptor
fiCompositeFontDescriptor :: Maybe FontDescriptor
  }
  deriving (Int -> FIComposite -> ShowS
[FIComposite] -> ShowS
FIComposite -> String
(Int -> FIComposite -> ShowS)
-> (FIComposite -> String)
-> ([FIComposite] -> ShowS)
-> Show FIComposite
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FIComposite] -> ShowS
$cshowList :: [FIComposite] -> ShowS
show :: FIComposite -> String
$cshow :: FIComposite -> String
showsPrec :: Int -> FIComposite -> ShowS
$cshowsPrec :: Int -> FIComposite -> ShowS
Show)

-- | Glyph widths for CID fonts
data CIDFontWidths = CIDFontWidths {
  CIDFontWidths -> Map Int Double
cidFontWidthsChars :: Map Int Double,
  CIDFontWidths -> [(Int, Int, Double)]
cidFontWidthsRanges :: [(Int, Int, Double)]
  }
  deriving (Int -> CIDFontWidths -> ShowS
[CIDFontWidths] -> ShowS
CIDFontWidths -> String
(Int -> CIDFontWidths -> ShowS)
-> (CIDFontWidths -> String)
-> ([CIDFontWidths] -> ShowS)
-> Show CIDFontWidths
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CIDFontWidths] -> ShowS
$cshowList :: [CIDFontWidths] -> ShowS
show :: CIDFontWidths -> String
$cshow :: CIDFontWidths -> String
showsPrec :: Int -> CIDFontWidths -> ShowS
$cshowsPrec :: Int -> CIDFontWidths -> ShowS
Show)

instance Monoid CIDFontWidths where
  mempty :: CIDFontWidths
mempty = CIDFontWidths :: Map Int Double -> [(Int, Int, Double)] -> CIDFontWidths
CIDFontWidths {
    cidFontWidthsChars :: Map Int Double
cidFontWidthsChars = Map Int Double
forall a. Monoid a => a
mempty,
    cidFontWidthsRanges :: [(Int, Int, Double)]
cidFontWidthsRanges = [(Int, Int, Double)]
forall a. Monoid a => a
mempty
    }
  CIDFontWidths
w1 mappend :: CIDFontWidths -> CIDFontWidths -> CIDFontWidths
`mappend` CIDFontWidths
w2 = CIDFontWidths :: Map Int Double -> [(Int, Int, Double)] -> CIDFontWidths
CIDFontWidths {
    cidFontWidthsChars :: Map Int Double
cidFontWidthsChars = CIDFontWidths -> Map Int Double
cidFontWidthsChars CIDFontWidths
w1
        Map Int Double -> Map Int Double -> Map Int Double
forall a. Monoid a => a -> a -> a
`mappend` CIDFontWidths -> Map Int Double
cidFontWidthsChars CIDFontWidths
w2,
    cidFontWidthsRanges :: [(Int, Int, Double)]
cidFontWidthsRanges = CIDFontWidths -> [(Int, Int, Double)]
cidFontWidthsRanges CIDFontWidths
w1
        [(Int, Int, Double)]
-> [(Int, Int, Double)] -> [(Int, Int, Double)]
forall a. Monoid a => a -> a -> a
`mappend` CIDFontWidths -> [(Int, Int, Double)]
cidFontWidthsRanges CIDFontWidths
w2
    }

instance Semigroup CIDFontWidths where
  <> :: CIDFontWidths -> CIDFontWidths -> CIDFontWidths
(<>) = CIDFontWidths -> CIDFontWidths -> CIDFontWidths
forall a. Monoid a => a -> a -> a
mappend

-- | Returns the Y coordinates for a bbox of a glyph of a font, in
-- text space units. Defaults to (0,1) if no FontDescriptor is
-- present.
--
-- Maybe for vertical scripts, there are individual heights for the
-- glyphs, so this takes a glyph code as second argument.
getGlyphYCoordinates :: FontInfo -> Int -> (Double, Double)
getGlyphYCoordinates :: FontInfo -> Int -> (Double, Double)
getGlyphYCoordinates (FontInfoComposite FIComposite
fi) =
  (Double, Double) -> Int -> (Double, Double)
forall a b. a -> b -> a
const ((Double, Double) -> Int -> (Double, Double))
-> (Double, Double) -> Int -> (Double, Double)
forall a b. (a -> b) -> a -> b
$ (Double, Double) -> Maybe (Double, Double) -> (Double, Double)
forall a. a -> Maybe a -> a
fromMaybe (Double
0,Double
1) (Maybe (Double, Double) -> (Double, Double))
-> Maybe (Double, Double) -> (Double, Double)
forall a b. (a -> b) -> a -> b
$ Maybe (Maybe (Double, Double)) -> Maybe (Double, Double)
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Maybe (Maybe (Double, Double)) -> Maybe (Double, Double))
-> Maybe (Maybe (Double, Double)) -> Maybe (Double, Double)
forall a b. (a -> b) -> a -> b
$ (FontDescriptor -> Maybe (Double, Double))
-> Maybe FontDescriptor -> Maybe (Maybe (Double, Double))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Double -> FontDescriptor -> Maybe (Double, Double)
fdYCoordinates Double
1000) (Maybe FontDescriptor -> Maybe (Maybe (Double, Double)))
-> Maybe FontDescriptor -> Maybe (Maybe (Double, Double))
forall a b. (a -> b) -> a -> b
$ FIComposite -> Maybe FontDescriptor
fiCompositeFontDescriptor FIComposite
fi
getGlyphYCoordinates (FontInfoSimple FISimple
fi) =
  (Double, Double) -> Int -> (Double, Double)
forall a b. a -> b -> a
const ((Double, Double) -> Int -> (Double, Double))
-> (Double, Double) -> Int -> (Double, Double)
forall a b. (a -> b) -> a -> b
$ (Double, Double) -> Maybe (Double, Double) -> (Double, Double)
forall a. a -> Maybe a -> a
fromMaybe (Double
0,Double
1) (Maybe (Double, Double) -> (Double, Double))
-> Maybe (Double, Double) -> (Double, Double)
forall a b. (a -> b) -> a -> b
$ Maybe (Maybe (Double, Double)) -> Maybe (Double, Double)
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Maybe (Maybe (Double, Double)) -> Maybe (Double, Double))
-> Maybe (Maybe (Double, Double)) -> Maybe (Double, Double)
forall a b. (a -> b) -> a -> b
$ (FontDescriptor -> Maybe (Double, Double))
-> Maybe FontDescriptor -> Maybe (Maybe (Double, Double))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Double -> FontDescriptor -> Maybe (Double, Double)
fdYCoordinates Double
1000) (Maybe FontDescriptor -> Maybe (Maybe (Double, Double)))
-> Maybe FontDescriptor -> Maybe (Maybe (Double, Double))
forall a b. (a -> b) -> a -> b
$ FISimple -> Maybe FontDescriptor
fiSimpleFontDescriptor FISimple
fi

fdYCoordinates :: Double -> FontDescriptor -> Maybe (Double, Double)
fdYCoordinates :: Double -> FontDescriptor -> Maybe (Double, Double)
fdYCoordinates Double
scaling FontDescriptor
fd =
  Maybe (Double, Double)
-> ((Double, Double) -> Maybe (Double, Double))
-> Maybe (Double, Double)
-> Maybe (Double, Double)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Maybe (Double, Double)
cap (Double, Double) -> Maybe (Double, Double)
forall a. a -> Maybe a
Just (Maybe (Double, Double) -> Maybe (Double, Double))
-> Maybe (Double, Double) -> Maybe (Double, Double)
forall a b. (a -> b) -> a -> b
$          -- third: try CapHeight
  Maybe (Double, Double)
-> ((Double, Double) -> Maybe (Double, Double))
-> Maybe (Double, Double)
-> Maybe (Double, Double)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Maybe (Double, Double)
descAsc (Double, Double) -> Maybe (Double, Double)
forall a. a -> Maybe a
Just (Maybe (Double, Double) -> Maybe (Double, Double))
-> Maybe (Double, Double) -> Maybe (Double, Double)
forall a b. (a -> b) -> a -> b
$      -- second: try Descent and Ascent
  (Rectangle Double -> (Double, Double))
-> Maybe (Rectangle Double) -> Maybe (Double, Double)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Rectangle Double -> (Double, Double)
bbox (Maybe (Rectangle Double) -> Maybe (Double, Double))
-> Maybe (Rectangle Double) -> Maybe (Double, Double)
forall a b. (a -> b) -> a -> b
$ FontDescriptor -> Maybe (Rectangle Double)
fdFontBBox FontDescriptor
fd -- first: try FontBBox
  where
    bbox :: Rectangle Double -> (Double, Double)
bbox (Rectangle Double
_ Double
b Double
_ Double
t) = (Double
b Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
scaling, Double
t Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
scaling)
    descAsc :: Maybe (Double, Double)
descAsc = (,) (Double -> Double -> (Double, Double))
-> Maybe Double -> Maybe (Double -> (Double, Double))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Double -> Double) -> Maybe Double -> Maybe Double
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
scaling) (Maybe Double -> Maybe Double) -> Maybe Double -> Maybe Double
forall a b. (a -> b) -> a -> b
$ FontDescriptor -> Maybe Double
fdDescent FontDescriptor
fd) Maybe (Double -> (Double, Double))
-> Maybe Double -> Maybe (Double, Double)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((Double -> Double) -> Maybe Double -> Maybe Double
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
scaling) (Maybe Double -> Maybe Double) -> Maybe Double -> Maybe Double
forall a b. (a -> b) -> a -> b
$ FontDescriptor -> Maybe Double
fdAscent FontDescriptor
fd)
    cap :: Maybe (Double, Double)
cap = (,) (Double -> Double -> (Double, Double))
-> Maybe Double -> Maybe (Double -> (Double, Double))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Double -> Maybe Double
forall a. a -> Maybe a
Just Double
0.0) Maybe (Double -> (Double, Double))
-> Maybe Double -> Maybe (Double, Double)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((Double -> Double) -> Maybe Double -> Maybe Double
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
scaling) (Maybe Double -> Maybe Double) -> Maybe Double -> Maybe Double
forall a b. (a -> b) -> a -> b
$ FontDescriptor -> Maybe Double
fdCapHeight FontDescriptor
fd)

simpleFontEncodingDecode :: SimpleFontEncoding -> Word8 -> Maybe Text
simpleFontEncodingDecode :: SimpleFontEncoding -> Word8 -> Maybe Text
simpleFontEncodingDecode SimpleFontEncoding
enc Word8
code =
  case Word8 -> [(Word8, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Word8
code (SimpleFontEncoding -> [(Word8, ByteString)]
simpleFontDifferences SimpleFontEncoding
enc) of
    Maybe ByteString
Nothing ->
      case SimpleFontEncoding -> FontBaseEncoding
simpleFontBaseEncoding SimpleFontEncoding
enc of
        FontBaseEncoding
FontBaseEncodingWinAnsi -> Word8 -> Map Word8 Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Word8
code Map Word8 Text
WinAnsi.encoding
        FontBaseEncoding
FontBaseEncodingMacRoman -> Word8 -> Map Word8 Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Word8
code Map Word8 Text
MacRoman.encoding
    Just ByteString
glyphName ->
      case ByteString -> Map ByteString Char -> Maybe Char
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ByteString
glyphName Map ByteString Char
adobeGlyphList of
        Just Char
c -> Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack [Char
c]
        Maybe Char
Nothing ->
          case ByteString -> Map ByteString Char -> Maybe Char
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ByteString
glyphName Map ByteString Char
texGlyphList of
            Maybe Char
Nothing-> Maybe Text
forall a. Maybe a
Nothing
            Just Char
c -> Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack [Char
c]

-- | Make `CIDFontWidths` from value of \"W\" key in descendant font
makeCIDFontWidths :: Array -> Either String CIDFontWidths
makeCIDFontWidths :: Array -> Either String CIDFontWidths
makeCIDFontWidths Array
vals = CIDFontWidths -> [Object] -> Maybe CIDFontWidths
go CIDFontWidths
forall a. Monoid a => a
mempty (Array -> [Object]
forall a. Vector a -> [a]
Vector.toList Array
vals)
  Maybe CIDFontWidths -> String -> Either String CIDFontWidths
forall a. Maybe a -> String -> Either String a
`notice` (String
"Can't parse CIDFont width " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Array -> String
forall a. Show a => a -> String
show Array
vals)
  where
  go :: CIDFontWidths -> [Object] -> Maybe CIDFontWidths
go CIDFontWidths
res [] = CIDFontWidths -> Maybe CIDFontWidths
forall (m :: * -> *) a. Monad m => a -> m a
return CIDFontWidths
res
  go CIDFontWidths
res (x1 :: Object
x1@Number{} : x2 :: Object
x2@Number{} : x3 :: Object
x3@Number{} : [Object]
xs) = do
    Int
n1 <- Object -> Maybe Int
intValue Object
x1
    Int
n2 <- Object -> Maybe Int
intValue Object
x2
    Double
n3 <- Object -> Maybe Double
realValue Object
x3
    CIDFontWidths -> [Object] -> Maybe CIDFontWidths
go CIDFontWidths
res {cidFontWidthsRanges :: [(Int, Int, Double)]
cidFontWidthsRanges = (Int
n1, Int
n2, Double
n3) (Int, Int, Double) -> [(Int, Int, Double)] -> [(Int, Int, Double)]
forall a. a -> [a] -> [a]
: CIDFontWidths -> [(Int, Int, Double)]
cidFontWidthsRanges CIDFontWidths
res} [Object]
xs
  go CIDFontWidths
res (Object
x : Array Array
arr : [Object]
xs) = do
    Int
n <- Object -> Maybe Int
intValue Object
x
    [Double]
ws <- [Object] -> (Object -> Maybe Double) -> Maybe [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
arr) Object -> Maybe Double
realValue
    CIDFontWidths -> [Object] -> Maybe CIDFontWidths
go CIDFontWidths
res {cidFontWidthsChars :: Map Int Double
cidFontWidthsChars = [(Int, Double)] -> Map Int Double
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([Int] -> [Double] -> [(Int, Double)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
n ..] [Double]
ws)
        Map Int Double -> Map Int Double -> Map Int Double
forall a. Monoid a => a -> a -> a
`mappend` CIDFontWidths -> Map Int Double
cidFontWidthsChars CIDFontWidths
res} [Object]
xs
  go CIDFontWidths
_ [Object]
_ = Maybe CIDFontWidths
forall a. Maybe a
Nothing

-- | Get glyph width by glyph code
cidFontGetWidth :: CIDFontWidths -> Int -> Maybe Double
cidFontGetWidth :: CIDFontWidths -> Int -> Maybe Double
cidFontGetWidth CIDFontWidths
w Int
code =
  case Int -> Map Int Double -> Maybe Double
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Int
code (CIDFontWidths -> Map Int Double
cidFontWidthsChars CIDFontWidths
w) of
    Just Double
width -> Double -> Maybe Double
forall a. a -> Maybe a
Just Double
width
    Maybe Double
Nothing -> case ((Int, Int, Double) -> Bool)
-> [(Int, Int, Double)] -> Maybe (Int, Int, Double)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\(Int
start, Int
end, Double
_) -> Int
code Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
start Bool -> Bool -> Bool
&& Int
code Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
end)
                         (CIDFontWidths -> [(Int, Int, Double)]
cidFontWidthsRanges CIDFontWidths
w) of
                 Just (Int
_, Int
_, Double
width) -> Double -> Maybe Double
forall a. a -> Maybe a
Just Double
width
                 Maybe (Int, Int, Double)
_ -> Maybe Double
forall a. Maybe a
Nothing

-- | Decode string into list of glyphs and their widths
fontInfoDecodeGlyphs :: FontInfo -> ByteString -> [(Glyph, Double)]
fontInfoDecodeGlyphs :: FontInfo -> ByteString -> [(Glyph, Double)]
fontInfoDecodeGlyphs fInfo :: FontInfo
fInfo@(FontInfoSimple FISimple
fi) = \ByteString
bs ->
  ((Word8 -> (Glyph, Double)) -> [Word8] -> [(Glyph, Double)])
-> [Word8] -> (Word8 -> (Glyph, Double)) -> [(Glyph, Double)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Word8 -> (Glyph, Double)) -> [Word8] -> [(Glyph, Double)]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString -> [Word8]
BS.unpack ByteString
bs) ((Word8 -> (Glyph, Double)) -> [(Glyph, Double)])
-> (Word8 -> (Glyph, Double)) -> [(Glyph, Double)]
forall a b. (a -> b) -> a -> b
$ \Word8
c ->
    let code :: Int
code = Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
c
        txt :: Maybe Text
txt =
          case FISimple -> Maybe UnicodeCMap
fiSimpleUnicodeCMap FISimple
fi of
            Maybe UnicodeCMap
Nothing ->
              case FISimple -> Maybe SimpleFontEncoding
fiSimpleEncoding FISimple
fi of
                Maybe SimpleFontEncoding
Nothing ->
                  case ByteString -> Either UnicodeException Text
Text.decodeUtf8' ([Word8] -> ByteString
BS.pack [Word8
c]) of
                    Right Text
t -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
t
                    Either UnicodeException Text
_ -> Maybe Text
forall a. Maybe a
Nothing
                Just SimpleFontEncoding
enc ->
                  case SimpleFontEncoding -> Word8 -> Maybe Text
simpleFontEncodingDecode SimpleFontEncoding
enc Word8
c of
                    Just Text
t -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
t
                    Maybe Text
Nothing ->
                      case ByteString -> Either UnicodeException Text
Text.decodeUtf8' ([Word8] -> ByteString
BS.pack [Word8
c]) of
                        Right Text
t -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
t
                        Either UnicodeException Text
_ -> Maybe Text
forall a. Maybe a
Nothing
            Just UnicodeCMap
toUnicode ->
              case UnicodeCMap -> Int -> Maybe Text
unicodeCMapDecodeGlyph UnicodeCMap
toUnicode Int
code of
                Just Text
t -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
t
                Maybe Text
Nothing ->
                  case FISimple -> Maybe SimpleFontEncoding
fiSimpleEncoding FISimple
fi of
                    Maybe SimpleFontEncoding
Nothing -> Maybe Text
forall a. Maybe a
Nothing
                    Just SimpleFontEncoding
enc ->
                      case SimpleFontEncoding -> Word8 -> Maybe Text
simpleFontEncodingDecode SimpleFontEncoding
enc Word8
c of
                        Just Text
t -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
t
                        Maybe Text
Nothing ->
                          case ByteString -> Either UnicodeException Text
Text.decodeUtf8' ([Word8] -> ByteString
BS.pack [Word8
c]) of
                            Right Text
t -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
t
                            Either UnicodeException Text
_ -> Maybe Text
forall a. Maybe a
Nothing
        width :: Double
width =
          case FISimple -> Maybe (Int, Int, [Double])
fiSimpleWidths FISimple
fi of
            Maybe (Int, Int, [Double])
Nothing -> Double
0
            Just (Int
firstChar, Int
lastChar, [Double]
widths) ->
              if Int
code Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
firstChar Bool -> Bool -> Bool
&& Int
code Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
lastChar
                  Bool -> Bool -> Bool
&& (Int
code Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
firstChar) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< [Double] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Double]
widths
                 then let Vector Double
w Double
_ = Transform Double -> Vector Double -> Vector Double
forall a. Num a => Transform a -> Vector a -> Vector a
transform (FISimple -> Transform Double
fiSimpleFontMatrix FISimple
fi) (Vector Double -> Vector Double) -> Vector Double -> Vector Double
forall a b. (a -> b) -> a -> b
$
                            Double -> Double -> Vector Double
forall a. a -> a -> Vector a
Vector ([Double]
widths [Double] -> Int -> Double
forall a. [a] -> Int -> a
!! (Int
code Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
firstChar)) Double
0
                      in Double
w
                 else Double
0
        (Double
yBottom, Double
yTop) = FontInfo -> Int -> (Double, Double)
getGlyphYCoordinates FontInfo
fInfo Int
code
    in (Glyph :: Int -> Vector Double -> Vector Double -> Maybe Text -> Glyph
Glyph {
      glyphCode :: Int
glyphCode = Int
code,
      glyphTopLeft :: Vector Double
glyphTopLeft = Double -> Double -> Vector Double
forall a. a -> a -> Vector a
Vector Double
0 Double
yBottom,
      glyphBottomRight :: Vector Double
glyphBottomRight = Double -> Double -> Vector Double
forall a. a -> a -> Vector a
Vector Double
width Double
yTop,
      glyphText :: Maybe Text
glyphText = Maybe Text
txt
      }, Double
width)
fontInfoDecodeGlyphs fInfo :: FontInfo
fInfo@(FontInfoComposite FIComposite
fi) = \ByteString
bs ->
  case FIComposite -> Maybe UnicodeCMap
fiCompositeUnicodeCMap FIComposite
fi of
    Maybe UnicodeCMap
Nothing ->  -- XXX: use encoding here
      [Word8] -> [(Glyph, Double)]
tryDecode2byte ([Word8] -> [(Glyph, Double)]) -> [Word8] -> [(Glyph, Double)]
forall a b. (a -> b) -> a -> b
$ ByteString -> [Word8]
BS.unpack ByteString
bs
    Just UnicodeCMap
toUnicode ->
      let getWidth :: Int -> Double
getWidth = Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe (FIComposite -> Double
fiCompositeDefaultWidth FIComposite
fi)
                   (Maybe Double -> Double) -> (Int -> Maybe Double) -> Int -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CIDFontWidths -> Int -> Maybe Double
cidFontGetWidth (FIComposite -> CIDFontWidths
fiCompositeWidths FIComposite
fi)
      in (Int -> Double)
-> UnicodeCMap -> FontInfo -> ByteString -> [(Glyph, Double)]
cmapDecodeString Int -> Double
getWidth UnicodeCMap
toUnicode FontInfo
fInfo ByteString
bs
  where
  -- Most of the time composite fonts have 2-byte encoding,
  -- so lets try that for now.
  tryDecode2byte :: [Word8] -> [(Glyph, Double)]
tryDecode2byte (Word8
b1:Word8
b2:[Word8]
rest) =
    let code :: Int
code = Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
b1 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
255 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
b2
        width :: Double
width = (Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
1000) (Double -> Double) -> Double -> Double
forall a b. (a -> b) -> a -> b
$ Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe (FIComposite -> Double
fiCompositeDefaultWidth FIComposite
fi)
                         (Maybe Double -> Double) -> Maybe Double -> Double
forall a b. (a -> b) -> a -> b
$ CIDFontWidths -> Int -> Maybe Double
cidFontGetWidth (FIComposite -> CIDFontWidths
fiCompositeWidths FIComposite
fi) Int
code
        txt :: Maybe Text
txt =
          case ByteString -> Either UnicodeException Text
Text.decodeUtf8' ([Word8] -> ByteString
BS.pack [Word8
b1, Word8
b2]) of
            Right Text
t -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
t
            Either UnicodeException Text
_ -> Maybe Text
forall a. Maybe a
Nothing
        (Double
yBottom, Double
yTop) = FontInfo -> Int -> (Double, Double)
getGlyphYCoordinates FontInfo
fInfo Int
code
        g :: Glyph
g = Glyph :: Int -> Vector Double -> Vector Double -> Maybe Text -> Glyph
Glyph {
          glyphCode :: Int
glyphCode = Int
code,
          glyphTopLeft :: Vector Double
glyphTopLeft = Double -> Double -> Vector Double
forall a. a -> a -> Vector a
Vector Double
0 Double
yBottom,
          glyphBottomRight :: Vector Double
glyphBottomRight = Double -> Double -> Vector Double
forall a. a -> a -> Vector a
Vector Double
width Double
yTop,
          glyphText :: Maybe Text
glyphText = Maybe Text
txt
          }
    in (Glyph
g, Double
width) (Glyph, Double) -> [(Glyph, Double)] -> [(Glyph, Double)]
forall a. a -> [a] -> [a]
: [Word8] -> [(Glyph, Double)]
tryDecode2byte [Word8]
rest
  tryDecode2byte [Word8]
_ = []

cmapDecodeString
  :: (Int -> Double)
  -> UnicodeCMap
  -> FontInfo
  -> ByteString
  -> [(Glyph, Double)]
cmapDecodeString :: (Int -> Double)
-> UnicodeCMap -> FontInfo -> ByteString -> [(Glyph, Double)]
cmapDecodeString Int -> Double
getWidth UnicodeCMap
cmap FontInfo
fInfo ByteString
str = ByteString -> [(Glyph, Double)]
go ByteString
str
  where
  go :: ByteString -> [(Glyph, Double)]
go ByteString
s =
    case UnicodeCMap -> ByteString -> Maybe (Int, ByteString)
unicodeCMapNextGlyph UnicodeCMap
cmap ByteString
s of
      Maybe (Int, ByteString)
Nothing -> []
      Just (Int
g, ByteString
rest) ->
        let width :: Double
width = Int -> Double
getWidth Int
g Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
1000
            (Double
yBottom, Double
yTop) = FontInfo -> Int -> (Double, Double)
getGlyphYCoordinates FontInfo
fInfo Int
g
            glyph :: Glyph
glyph = Glyph :: Int -> Vector Double -> Vector Double -> Maybe Text -> Glyph
Glyph {
          glyphCode :: Int
glyphCode = Int
g,
          glyphTopLeft :: Vector Double
glyphTopLeft = Double -> Double -> Vector Double
forall a. a -> a -> Vector a
Vector Double
0 Double
yBottom,
          glyphBottomRight :: Vector Double
glyphBottomRight = Double -> Double -> Vector Double
forall a. a -> a -> Vector a
Vector Double
width Double
yTop,
          glyphText :: Maybe Text
glyphText = UnicodeCMap -> Int -> Maybe Text
unicodeCMapDecodeGlyph UnicodeCMap
cmap Int
g
          }
        in (Glyph
glyph, Double
width) (Glyph, Double) -> [(Glyph, Double)] -> [(Glyph, Double)]
forall a. a -> [a] -> [a]
: ByteString -> [(Glyph, Double)]
go ByteString
rest