webify-0.1.7.0: src/EOT.hs

module EOT(
  generate
) where

import           Control.Monad
import           Data.Binary.Put
import           Data.Bits
import qualified Data.ByteString    as B
import           Data.List          (find)
import           Data.Maybe         (fromJust, isJust)
import           Data.Text.Encoding (encodeUtf16LE)
import           Font
import           Utils

putULong :: ULong -> Put
putULong = putWord32le

putByte :: Byte -> Put
putByte = putWord8

putUShort :: UShort -> Put
putUShort = putWord16le

match :: UShort -> Name -> Maybe NameRecord
match nameId' name' =
  find predicate records
  where
    records = nameRecords name'
    predicate nr =
      ((platformId nr == 1 &&
        encodingId nr == 0 &&
        languageId nr == 0) ||
       (platformId nr == 3 &&
        encodingId nr == 1 &&
        languageId nr == 0x0409)) &&
      nameId nr == nameId'

putNameStr :: Name -> UShort -> PutM ()
putNameStr name' i | isJust mnameRecord = do
  putUShort $ fromIntegral $ B.length encodedStr
  putByteString encodedStr
  putUShort 0
                   | otherwise = do
  putUShort 0
  putUShort 0
  where mnameRecord = match i name'
        nameRecord = fromJust mnameRecord
        encodedStr = encodeUtf16LE $ str nameRecord


payload :: Font f => f -> B.ByteString -> Put
payload font rawFont = do
  putULong (fromIntegral (B.length rawFont)) -- font size
  putULong 0x00020001
  putULong 0 -- flags
  let name' = name font
  mapM_ putByte $ os2panose font
  putByte 0x01
  putByte (if testBit (os2fsSelection font) 0 then 0x01 else 0)
  putULong $ fromIntegral $ os2usWeightClass font
  putUShort 0  --  embedding permission putUShort $ fsType os
  putUShort 0x504C
  putULong $ os2ulUnicodeRange1 font
  putULong $ os2ulUnicodeRange2 font
  putULong $ os2ulUnicodeRange3 font
  putULong $ os2ulUnicodeRange4 font
  putULong $ os2ulCodePageRange1 font
  putULong $ os2ulCodePageRange2 font
  putULong $ headCheckSumAdjusment font
  replicateM_ 4 (putULong 0)
  putUShort 0
  putNameStr name' 1
  putNameStr name' 2
  putNameStr name' 5
  putNameStr name' 4
  putUShort 0 -- RootString
  putByteString rawFont


combine :: B.ByteString -> PutM ()
combine rest = do
  putULong $ fromIntegral $ B.length rest + 4
  putByteString rest

generate :: Font f => f -> B.ByteString -> B.ByteString
generate font rawFont =
  let rest = toStrict $ runPut (payload font rawFont)
  in toStrict $ runPut $ combine rest