{-# LANGUAGE OverloadedStrings #-}

module PDF.OpenType (cmap) where

import Numeric (readInt)
import Data.Char (chr)

import Data.Word
import Data.Bits

import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BSC

import Data.Attoparsec.ByteString (Parser, parseOnly, word8, string)
import qualified Data.Attoparsec.ByteString as AP
import Data.Attoparsec.Combinator

import Control.Applicative

import Debug.Trace

import PDF.Definition

data Table = Table String Integer Integer
  deriving (Int -> Table -> ShowS
[Table] -> ShowS
Table -> String
(Int -> Table -> ShowS)
-> (Table -> String) -> ([Table] -> ShowS) -> Show Table
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Table] -> ShowS
$cshowList :: [Table] -> ShowS
show :: Table -> String
$cshow :: Table -> String
showsPrec :: Int -> Table -> ShowS
$cshowsPrec :: Int -> Table -> ShowS
Show)

data EncRecord = EncRecord Integer Integer Integer
  deriving (Int -> EncRecord -> ShowS
[EncRecord] -> ShowS
EncRecord -> String
(Int -> EncRecord -> ShowS)
-> (EncRecord -> String)
-> ([EncRecord] -> ShowS)
-> Show EncRecord
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [EncRecord] -> ShowS
$cshowList :: [EncRecord] -> ShowS
show :: EncRecord -> String
$cshow :: EncRecord -> String
showsPrec :: Int -> EncRecord -> ShowS
$cshowsPrec :: Int -> EncRecord -> ShowS
Show)

{-
test f = do
  c <- BS.readFile f
  let bs = cmap c
  return bs
-}

cmap :: ByteString -> CMap
cmap :: ByteString -> CMap
cmap ByteString
c = case Parser [Table] -> ByteString -> Either String [Table]
forall a. Parser a -> ByteString -> Either String a
parseOnly (Parser ByteString Int
offsetTable Parser ByteString Int -> (Int -> Parser [Table]) -> Parser [Table]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Parser [Table]
tableRecords) ByteString
c of
  Right [Table]
b -> let b' :: ByteString
b' = ([Table] -> ByteString
takeCmap [Table]
b)
             in case Parser [EncRecord] -> ByteString -> Either String [EncRecord]
forall a. Parser a -> ByteString -> Either String a
parseOnly Parser [EncRecord]
cmapEncRecords ByteString
b' of
                  Right [EncRecord]
records -> (EncRecord -> CMap) -> [EncRecord] -> CMap
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (ByteString -> EncRecord -> CMap
subtable ByteString
b') [EncRecord]
records
                  Left String
e -> String -> CMap
forall a. HasCallStack => String -> a
error String
e
  Left String
e -> String -> CMap
forall a. HasCallStack => String -> a
error String
e
  where
    offsetTable :: Parser ByteString Int
offsetTable = do
      Parser ByteString
sfntVersion
      Integer
n <- Parser Integer
numTables
      Parser Integer
searchRange Parser Integer -> Parser Integer -> Parser Integer
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser Integer
entrySelector Parser Integer -> Parser Integer -> Parser Integer
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser Integer
rangeShift
      Int -> Parser ByteString Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Parser ByteString Int) -> Int -> Parser ByteString Int
forall a b. (a -> b) -> a -> b
$ Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
n

    takeCmap :: [Table] -> ByteString
takeCmap ((Table String
"cmap" Integer
start Integer
end):[Table]
_)
      = Int -> ByteString -> ByteString
BS.take (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
end) (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BS.drop (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
start) ByteString
c
    takeCmap (Table
_:[Table]
rest) = [Table] -> ByteString
takeCmap [Table]
rest
    takeCmap [] = String -> ByteString
forall a. HasCallStack => String -> a
error String
"no cmap"

    cmapEncRecords :: Parser [EncRecord]
cmapEncRecords =
      Parser Integer
cmapVersion Parser Integer -> Parser Integer -> Parser Integer
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
      Parser Integer
numEncRecords Parser Integer
-> (Integer -> Parser [EncRecord]) -> Parser [EncRecord]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
      (Int -> Parser [EncRecord]
encodeRecords (Int -> Parser [EncRecord])
-> (Integer -> Int) -> Integer -> Parser [EncRecord]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral)
      
subtable :: ByteString -> EncRecord -> CMap
subtable ByteString
c (EncRecord Integer
pid Integer
eid Integer
offset) =
  let body :: ByteString
body = Int -> ByteString -> ByteString
BS.drop (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
offset) ByteString
c
      format :: Integer
format = ByteString -> Integer
fromBytes (ByteString -> Integer) -> ByteString -> Integer
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BS.take Int
2 ByteString
body
  in case Parser CMap -> ByteString -> Either String CMap
forall a. Parser a -> ByteString -> Either String a
parseOnly (Integer -> Parser CMap
parserByFormat Integer
format) ByteString
body of
       Right CMap
b -> CMap
b
       Left String
e -> String -> CMap
forall a. HasCallStack => String -> a
error String
e

parserByFormat :: Integer -> Parser CMap
parserByFormat :: Integer -> Parser CMap
parserByFormat Integer
14 = do
  Integer
format <- Parser Integer
getUint16
  Integer
length <- Parser Integer
getUint32
  ByteString
rest <- (Int -> Parser ByteString
AP.take (Int -> Parser ByteString)
-> (Integer -> Int) -> Integer -> Parser ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Int
forall a. Num a => Integer -> a
fromInteger) Integer
length
  CMap -> Parser CMap
forall (m :: * -> *) a. Monad m => a -> m a
return (CMap -> Parser CMap) -> CMap -> Parser CMap
forall a b. (a -> b) -> a -> b
$ []

parserByFormat Integer
12 = do
  Integer
format <- Parser Integer
getUint16
  Integer
reserved <- Parser Integer
getUint16
  Integer
length <- Parser Integer
getUint32
  Integer
language <- Parser Integer
getUint32
  Int
numGroups <- Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Integer -> Int) -> Parser Integer -> Parser ByteString Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Integer
getUint32
  [CMap]
seqMapGroups <- Int -> Parser CMap -> Parser ByteString [CMap]
forall (m :: * -> *) a. Monad m => Int -> m a -> m [a]
count (Int
numGroups) Parser CMap
seqMapGroup
  CMap -> Parser CMap
forall (m :: * -> *) a. Monad m => a -> m a
return (CMap -> Parser CMap) -> CMap -> Parser CMap
forall a b. (a -> b) -> a -> b
$ [CMap] -> CMap
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [CMap]
seqMapGroups

  where
    seqMapGroup :: Parser CMap
    seqMapGroup :: Parser CMap
seqMapGroup = do
      Int
startCharCode <- Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Integer -> Int) -> Parser Integer -> Parser ByteString Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Integer
getUint32
      Int
endCharCode <- Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Integer -> Int) -> Parser Integer -> Parser ByteString Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Integer
getUint32
      Int
startGlyphID  <- Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Integer -> Int) -> Parser Integer -> Parser ByteString Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Integer
getUint32
      CMap -> Parser CMap
forall (m :: * -> *) a. Monad m => a -> m a
return (CMap -> Parser CMap) -> CMap -> Parser CMap
forall a b. (a -> b) -> a -> b
$ Int -> [Int] -> CMap
forall a. Enum a => a -> [Int] -> [(a, String)]
toCmap Int
startGlyphID [Int
startCharCode .. Int
endCharCode]
    toCmap :: a -> [Int] -> [(a, String)]
toCmap a
gid [Int]
range = [a] -> [String] -> [(a, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip [a
gid ..] ([String] -> [(a, String)]) -> [String] -> [(a, String)]
forall a b. (a -> b) -> a -> b
$ (Int -> String) -> [Int] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((Char -> ShowS
forall a. a -> [a] -> [a]
:[])(Char -> String) -> (Int -> Char) -> Int -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Int -> Char
chr) [Int]
range

parserByFormat Integer
4 = do
  Integer
format <- Parser Integer
getUint16
  Int
length <- Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Integer -> Int) -> Parser Integer -> Parser ByteString Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Integer
getUint16
  Integer
language <- Parser Integer
getUint16
  Int
segCount2 <- Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Integer -> Int) -> Parser Integer -> Parser ByteString Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Integer
getUint16
  Integer
searchRange <- Parser Integer
getUint16
  Integer
entrySlector <- Parser Integer
getUint16
  Integer
rangeShift <-Parser Integer
getUint16
  let segCount :: Int
segCount = Int
segCount2 Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2
  [Int]
endCodes <- Int -> Parser ByteString Int -> Parser ByteString [Int]
forall (m :: * -> *) a. Monad m => Int -> m a -> m [a]
count Int
segCount (Parser ByteString Int -> Parser ByteString [Int])
-> Parser ByteString Int -> Parser ByteString [Int]
forall a b. (a -> b) -> a -> b
$ Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Integer -> Int) -> Parser Integer -> Parser ByteString Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Integer
getUint16
  ByteString
reservedPad <- [Word8] -> Parser ByteString
contiguous [Word8
0x00, Word8
0x00]
  [Int]
startCodes <- Int -> Parser ByteString Int -> Parser ByteString [Int]
forall (m :: * -> *) a. Monad m => Int -> m a -> m [a]
count Int
segCount (Parser ByteString Int -> Parser ByteString [Int])
-> Parser ByteString Int -> Parser ByteString [Int]
forall a b. (a -> b) -> a -> b
$ Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Integer -> Int) -> Parser Integer -> Parser ByteString Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Integer
getUint16
  [Int]
idDelta <- Int -> Parser ByteString Int -> Parser ByteString [Int]
forall (m :: * -> *) a. Monad m => Int -> m a -> m [a]
count Int
segCount (Parser ByteString Int -> Parser ByteString [Int])
-> Parser ByteString Int -> Parser ByteString [Int]
forall a b. (a -> b) -> a -> b
$ Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Integer -> Int) -> Parser Integer -> Parser ByteString Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Integer
getUint16
  ByteString
rest <- Int -> Parser ByteString
AP.take (Int
length Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
16 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
segCount2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
3)
  CMap -> Parser CMap
forall (m :: * -> *) a. Monad m => a -> m a
return (CMap -> Parser CMap) -> CMap -> Parser CMap
forall a b. (a -> b) -> a -> b
$ [CMap] -> CMap
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([CMap] -> CMap) -> [CMap] -> CMap
forall a b. (a -> b) -> a -> b
$ [Int] -> [Int] -> [Int] -> ByteString -> [CMap]
getGlyphIDs [Int]
startCodes [Int]
endCodes [Int]
idDelta ByteString
rest

  where
    getGlyphIDs :: [Int] -> [Int] -> [Int] -> ByteString -> [CMap]
getGlyphIDs [] [Int]
_ [Int]
_ ByteString
_ = []
    getGlyphIDs (Int
s:[Int]
ss) (Int
e:[Int]
ee) (Int
d:[Int]
dd) ByteString
rest =
      -- take 2bytes from idRangeOffset[uint16]
      let rest' :: ByteString
rest' = Int -> ByteString -> ByteString
BS.drop Int
2 ByteString
rest
      in (Int -> Int -> Int -> ByteString -> CMap
getGlyphID Int
s Int
e Int
d ByteString
rest)CMap -> [CMap] -> [CMap]
forall a. a -> [a] -> [a]
:([Int] -> [Int] -> [Int] -> ByteString -> [CMap]
getGlyphIDs [Int]
ss [Int]
ee [Int]
dd ByteString
rest')

    getGlyphID :: Int -> Int -> Int -> ByteString
                -> CMap
    getGlyphID :: Int -> Int -> Int -> ByteString -> CMap
getGlyphID Int
start Int
end Int
delta ByteString
rest =
      let offset :: Int
offset = Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Integer -> Int) -> Integer -> Int
forall a b. (a -> b) -> a -> b
$ ByteString -> Integer
fromBytes (ByteString -> Integer) -> ByteString -> Integer
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BS.take Int
2 ByteString
rest
      in 
        if Int
offset Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
        then [Int] -> [String] -> CMap
forall a b. [a] -> [b] -> [(a, b)]
zip ((Int -> Int) -> [Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
delta) [Int
start .. Int
end])
                 ((Int -> String) -> [Int] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((Char -> ShowS
forall a. a -> [a] -> [a]
:[])(Char -> String) -> (Int -> Char) -> Int -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Int -> Char
chr) [Int
start .. Int
end])
        else [Int] -> [String] -> CMap
forall a b. [a] -> [b] -> [(a, b)]
zip ((Int -> Int) -> [Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Int -> ByteString -> Int -> Int
forall a. Num a => Int -> Int -> ByteString -> Int -> a
getRangeOffsetGlyphID Int
start Int
offset ByteString
rest) [Int
start .. Int
end])
                 ((Int -> String) -> [Int] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((Char -> ShowS
forall a. a -> [a] -> [a]
:[])(Char -> String) -> (Int -> Char) -> Int -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Int -> Char
chr) [Int
start .. Int
end])
             
    getRangeOffsetGlyphID :: Int -> Int -> ByteString -> Int -> a
getRangeOffsetGlyphID Int
s Int
o ByteString
bytestring Int
c =
      Integer -> a
forall a. Num a => Integer -> a
fromInteger (Integer -> a) -> Integer -> a
forall a b. (a -> b) -> a -> b
$ ByteString -> Integer
fromBytes (ByteString -> Integer) -> ByteString -> Integer
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BS.take Int
2 (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BS.drop (Int
o Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Int
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
s)) ByteString
bytestring

parserByFormat Integer
_ = CMap -> Parser CMap
forall (m :: * -> *) a. Monad m => a -> m a
return []


-- main tables

sfntVersion :: Parser ByteString
sfntVersion :: Parser ByteString
sfntVersion = [Word8] -> Parser ByteString
contiguous [Word8
0x00, Word8
0x01, Word8
0x00, Word8
0x00] Parser ByteString -> Parser ByteString -> Parser ByteString
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ByteString -> Parser ByteString
string ByteString
"OTTO"

numTables :: Parser Integer
numTables =  Parser Integer
getUint16
searchRange :: Parser Integer
searchRange = Parser Integer
getUint16
entrySelector :: Parser Integer
entrySelector = Parser Integer
getUint16
rangeShift :: Parser Integer
rangeShift = Parser Integer
getUint16

tableRecords :: Int -> Parser [Table]
tableRecords Int
n = Int -> Parser ByteString Table -> Parser [Table]
forall (m :: * -> *) a. Monad m => Int -> m a -> m [a]
count Int
n Parser ByteString Table
tableRecord

tableRecord :: Parser Table
tableRecord :: Parser ByteString Table
tableRecord = do
  String
tableTag <- ByteString -> String
BSC.unpack (ByteString -> String)
-> Parser ByteString -> Parser ByteString String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Parser ByteString
AP.take Int
4
  Integer
checkSum <- Parser Integer
getUint32
  Integer
offset <- Parser Integer
getUint32
  Integer
length <- Parser Integer
getUint32
  Table -> Parser ByteString Table
forall (m :: * -> *) a. Monad m => a -> m a
return (Table -> Parser ByteString Table)
-> Table -> Parser ByteString Table
forall a b. (a -> b) -> a -> b
$ String -> Integer -> Integer -> Table
Table String
tableTag Integer
offset Integer
length

getUint16 :: Parser Integer
getUint16 :: Parser Integer
getUint16 = ByteString -> Integer
fromBytes (ByteString -> Integer) -> Parser ByteString -> Parser Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Parser ByteString
AP.take Int
2

getUint32 :: Parser Integer
getUint32 :: Parser Integer
getUint32 = ByteString -> Integer
fromBytes (ByteString -> Integer) -> Parser ByteString -> Parser Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Parser ByteString
AP.take Int
4

tableTag :: Parser String
tableTag :: Parser ByteString String
tableTag = ByteString -> String
BSC.unpack (ByteString -> String)
-> Parser ByteString -> Parser ByteString String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Parser ByteString
AP.take Int
4

-- subtables

cmapVersion :: Parser Integer
cmapVersion = Parser Integer
getUint16
numEncRecords :: Parser Integer
numEncRecords = Parser Integer
getUint16

encodeRecords :: Int -> Parser [EncRecord]
encodeRecords Int
n = Int -> Parser ByteString EncRecord -> Parser [EncRecord]
forall (m :: * -> *) a. Monad m => Int -> m a -> m [a]
count Int
n Parser ByteString EncRecord
encodeRecord

encodeRecord :: Parser EncRecord
encodeRecord :: Parser ByteString EncRecord
encodeRecord = do
  Integer
platformID <- Parser Integer
getUint16
  Integer
encodingID <- Parser Integer
getUint16
  Integer
offset <- Parser Integer
getUint32
  EncRecord -> Parser ByteString EncRecord
forall (m :: * -> *) a. Monad m => a -> m a
return (EncRecord -> Parser ByteString EncRecord)
-> EncRecord -> Parser ByteString EncRecord
forall a b. (a -> b) -> a -> b
$ Integer -> Integer -> Integer -> EncRecord
EncRecord Integer
platformID Integer
encodingID Integer
offset


fromBytes :: ByteString -> Integer
fromBytes :: ByteString -> Integer
fromBytes = (Integer -> Word8 -> Integer) -> Integer -> ByteString -> Integer
forall a. (a -> Word8 -> a) -> a -> ByteString -> a
BS.foldl' Integer -> Word8 -> Integer
forall a a. (Bits a, Integral a, Num a) => a -> a -> a
f Integer
0
  where
    f :: a -> a -> a
f a
a a
b = a
a a -> Int -> a
forall a. Bits a => a -> Int -> a
`shiftL` Int
8 a -> a -> a
forall a. Bits a => a -> a -> a
.|. a -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
b

contiguous :: [Word8] -> Parser ByteString
contiguous :: [Word8] -> Parser ByteString
contiguous [Word8]
bs = [Word8] -> ByteString
BS.pack ([Word8] -> ByteString)
-> Parser ByteString [Word8] -> Parser ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Word8] -> Parser ByteString [Word8]
contiguous' [Word8]
bs
  where
    contiguous' :: [Word8] -> Parser ByteString [Word8]
contiguous' (Word8
b:[]) = (Word8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
:[]) (Word8 -> [Word8])
-> Parser ByteString Word8 -> Parser ByteString [Word8]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Word8 -> Parser ByteString Word8
word8 Word8
b
    contiguous' (Word8
b:[Word8]
bs) = do
      Word8
byte <- Word8 -> Parser ByteString Word8
word8 Word8
b
      [Word8]
rest <- [Word8] -> Parser ByteString [Word8]
contiguous' [Word8]
bs
      [Word8] -> Parser ByteString [Word8]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Word8] -> Parser ByteString [Word8])
-> [Word8] -> Parser ByteString [Word8]
forall a b. (a -> b) -> a -> b
$ (Word8
byteWord8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
:[Word8]
rest)