{-# LANGUAGE RecordWildCards #-} module Font( Font(..) -- parser , Byte , Font.Char , UShort , Short , FWord , UFWord , ULong , Fixed , getFixed , getULong , getUShort , getShort , getByte , Font.getChar , getFWord , getUFWord , getUFixed -- common font structure , TableDirectory(..) , Name(..) , NameRecord(..) , HMetric(..) , Hmtx(..) , OS2(..) , Head(..) , parseTableDirectory , parseTableDirectories , parseTable , parseOS2 , parseHead , parseName ) where import Control.Monad import Data.Binary.Strict.Get import qualified Data.ByteString as B import Data.ByteString.Char8 (unpack) import Data.Int import Data.Map hiding (map) import qualified Data.Text as T import Data.Text.Encoding import Data.Text.Encoding.Error import qualified Data.Vector as V import Data.Word import Utils -- font data types type Byte = Word8 type Char = Int8 type UShort = Word16 type Short = Int16 type FWord = Int16 type UFWord = Word16 type ULong = Word32 -- type Long = Int32 type Fixed = Word32 getFixed :: Get Fixed getFixed = liftM fromIntegral getWord32be getULong :: Get ULong getULong = getWord32be getUShort :: Get UShort getUShort = getWord16be getShort :: Get Short getShort = liftM fromIntegral getWord16be getByte :: Get Byte getByte = getWord8 getChar :: Get Font.Char getChar = liftM fromIntegral getWord8 getFWord :: Get FWord getFWord = getShort getUFWord :: Get UFWord getUFWord = getUShort -- format 2.14 getUFixed :: Get Double getUFixed = liftM ((/ 0x4000) . fromIntegral) getShort --- common parsing utils data TableDirectory = TableDirectory { tDTag :: String , tDCheckSum :: ULong , tDOffset :: ULong , tDLength :: ULong , tDRawData :: B.ByteString } deriving (Show) data NameRecord = NameRecord { platformId :: UShort , encodingId :: UShort , languageId :: UShort , nameId :: UShort , strLength :: UShort , strOffset :: UShort , str :: T.Text } deriving (Show) data Name = Name { formatSelector :: UShort , numberOfNameRecords :: UShort , storageOffset :: UShort , nameRecords :: [NameRecord] } deriving (Show) data HMetric = HMetric { advanceWidth :: UFWord , lsb :: FWord } deriving (Show) data Hmtx = Hmtx { hMetrics :: V.Vector HMetric , leftSideBearings :: [FWord] } deriving (Show) data OS2 = OS2 { os2Version :: UShort , xAvgCharWidth :: Short , usWeightClass :: UShort , usWidthClass :: UShort , fsType :: UShort , ySubscriptXSize :: Short , ySubscriptYSize :: Short , ySubscriptXOffset :: Short , ySubscriptYOffset :: Short , ySuperscriptXSize :: Short , ySuperscriptYSize :: Short , ySuperscriptXOffset :: Short , ySuperscriptYOffset :: Short , yStrikeoutSize :: Short , yStrikeoutPosition :: Short , sFamilyClass :: Short , panose :: [Byte] , ulUnicodeRange1 :: ULong , ulUnicodeRange2 :: ULong , ulUnicodeRange3 :: ULong , ulUnicodeRange4 :: ULong , aschVendID :: [Byte] , fsSelection :: UShort , usFirstCharIndex :: UShort , usLastCharIndex :: UShort , sTypoAscender :: UShort , sTypoDescender :: UShort , sTypoLineGap :: UShort , usWinAscent :: UShort , usWinDescent :: UShort , ulCodePageRange1 :: ULong , ulCodePageRange2 :: ULong } deriving (Show) parseTableDirectory :: B.ByteString -> Get TableDirectory parseTableDirectory font = do tDTag <- liftM unpack $ getByteString 4 tDCheckSum <- getULong tDOffset <- getULong tDLength <- getULong let tDRawData = substr (fromIntegral tDOffset) (fromIntegral tDLength) font return TableDirectory{..} parseTableDirectories :: B.ByteString -> Int -> Get (Map String TableDirectory) parseTableDirectories font n = do list <- replicateM n $ parseTableDirectory font return $ fromList $ map (\x -> (tDTag x, x)) list parseTable :: String -> Get a -> Map String TableDirectory -> B.ByteString -> a parseTable name' m tds font = fromRight $ runGet (do skip $ fromIntegral . tDOffset $ tds ! name' m) font parseOS2 :: Map String TableDirectory -> B.ByteString -> OS2 parseOS2 = parseTable "OS/2" (do os2Version <- getUShort unless (os2Version `elem` [1..4]) (error $ "unhandled os2 version " ++ show os2Version) xAvgCharWidth <- getShort usWeightClass <- getUShort usWidthClass <- getUShort fsType <- getUShort ySubscriptXSize <- getShort ySubscriptYSize <- getShort ySubscriptXOffset <- getShort ySubscriptYOffset <- getShort ySuperscriptXSize <- getShort ySuperscriptYSize <- getShort ySuperscriptXOffset <- getShort ySuperscriptYOffset <- getShort yStrikeoutSize <- getShort yStrikeoutPosition <- getShort sFamilyClass <- getShort panose <- replicateM 10 getByte ulUnicodeRange1 <- getULong ulUnicodeRange2 <- getULong ulUnicodeRange3 <- getULong ulUnicodeRange4 <- getULong aschVendID <- replicateM 4 getByte fsSelection <- getUShort usFirstCharIndex <- getUShort usLastCharIndex <- getUShort sTypoAscender <- getUShort sTypoDescender <- getUShort sTypoLineGap <- getUShort usWinAscent <- getUShort usWinDescent <- getUShort ulCodePageRange1 <- getULong ulCodePageRange2 <- getULong return OS2 {..}) data Head = Head { headVersion :: Fixed , fontRevision :: Fixed , checkSumAdjusment :: ULong , magicNumber :: ULong , headFlags :: UShort , unitsPerEm :: UShort , created :: B.ByteString , modified :: B.ByteString , xMin :: FWord , yMin :: FWord , xMax :: FWord , yMax :: FWord , macStyle :: UShort , lowestRecPPEM :: UShort , fontDirectionHint :: Short , indexToLocFormat :: Short , glyphDataFormat :: Short } deriving (Show) parseHead :: Map String TableDirectory -> B.ByteString -> Head parseHead = parseTable "head" (do headVersion <- getFixed fontRevision <- getFixed checkSumAdjusment <- getULong magicNumber <- getULong headFlags <- getUShort unitsPerEm <- getUShort created <- getByteString 8 modified <- getByteString 8 xMin <- getFWord yMin <- getFWord xMax <- getFWord yMax <- getFWord macStyle <- getUShort lowestRecPPEM <- getUShort fontDirectionHint <- getShort indexToLocFormat <- getShort glyphDataFormat <- getShort return Head{..}) parseNameRecord :: B.ByteString -> Int -> Get NameRecord parseNameRecord font storageOffset = do platformId <- getUShort encodingId <- getUShort languageId <- getUShort nameId <- getUShort strLength <- getUShort strOffset <- getUShort let str = decoder platformId encodingId $ substr (fromIntegral ((fromIntegral storageOffset :: Int) + fromIntegral strOffset)) (fromIntegral strLength) font return NameRecord{..} where decoder 3 _ = decodeUtf16BE decoder 2 _ = decodeUtf16BE decoder 1 _ = decodeUtf8With ignore decoder 0 _ = decodeUtf16BE decoder _ _ = decodeUtf16BE parseName ::Map String TableDirectory -> B.ByteString -> Name parseName tds font = fromRight $ runGet (do let tableStart = fromIntegral $ tDOffset $ tds ! "name" skip tableStart formatSelector <- getUShort numberOfNameRecords <- getUShort storageOffset <- getUShort nameRecords <- replicateM (fromIntegral numberOfNameRecords) $ parseNameRecord font (tableStart + fromIntegral storageOffset) return Name{..}) font class Font a where version :: a -> Fixed numTables :: a -> UShort tableDirectories :: a -> Map String TableDirectory -- os2 os2panose :: a -> [Byte] os2fsSelection :: a -> UShort os2usWeightClass :: a -> UShort os2ulUnicodeRange1 :: a -> ULong os2ulUnicodeRange2 :: a -> ULong os2ulUnicodeRange3 :: a -> ULong os2ulUnicodeRange4 :: a -> ULong os2ulCodePageRange1 :: a -> ULong os2ulCodePageRange2 :: a -> ULong -- head headCheckSumAdjusment :: a -> ULong -- name name :: a -> Name