webify 0.1.5.0 → 0.1.6.0
raw patch · 9 files changed
+1420/−3 lines, 9 files
Files
- src/EOT.hs +88/−0
- src/Font.hs +309/−0
- src/OTF.hs +52/−0
- src/SVG.hs +236/−0
- src/TTF.hs +583/−0
- src/Utils.hs +51/−0
- src/WOFF.hs +98/−0
- src/Webify.hs +1/−1
- webify.cabal +2/−2
+ src/EOT.hs view
@@ -0,0 +1,88 @@+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
+ src/Font.hs view
@@ -0,0 +1,309 @@+{-# 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.Error+import qualified Data.Vector as V+import Data.Word+import Utils+import Data.Text.Encoding++-- 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
+ src/OTF.hs view
@@ -0,0 +1,52 @@+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+{-# LANGUAGE RecordWildCards #-}++module OTF(+ OTF(..)+ , parse+) where++import qualified Data.ByteString as B+import Data.Binary.Strict.Get+import Data.Map+import Font++instance Font OTF where+ version = OTF.version+ numTables = OTF.numTables+ tableDirectories = OTF.tableDirectories+ os2panose = panose . os2+ os2fsSelection = fsSelection . os2+ os2usWeightClass = usWeightClass . os2+ os2ulUnicodeRange1 = ulUnicodeRange1 . os2+ os2ulUnicodeRange2 = ulUnicodeRange2 . os2+ os2ulUnicodeRange3 = ulUnicodeRange3 . os2+ os2ulUnicodeRange4 = ulUnicodeRange4 . os2+ os2ulCodePageRange1 = ulCodePageRange1 . os2+ os2ulCodePageRange2 = ulCodePageRange2 . os2+ headCheckSumAdjusment = checkSumAdjusment . OTF.head+ name = OTF.name++data OTF = OTF { version :: Fixed+ , numTables :: UShort+ , searchRange :: UShort+ , entrySelector :: UShort+ , rangeShift :: UShort+ , tableDirectories :: Map String TableDirectory+ , os2 :: OS2+ , head :: Head+ , name :: Name+ } deriving (Show)++parse :: B.ByteString -> Get OTF+parse font = do+ version <- getFixed+ numTables <- getUShort+ searchRange <- getUShort+ entrySelector <- getUShort+ rangeShift <- getUShort+ tableDirectories <- parseTableDirectories font (fromIntegral numTables)+ let os2 = parseOS2 tableDirectories font+ head = parseHead tableDirectories font+ name = parseName tableDirectories font+ return OTF{..}
+ src/SVG.hs view
@@ -0,0 +1,236 @@+module SVG(+ generate+) where++import Data.Bits+import qualified Data.ByteString as B+import Data.Char+import Data.List (find, foldl', intercalate)+import Data.Maybe (fromJust)+import qualified Data.Text as T+import qualified Data.Map as M+import TTF+import Font hiding (Char, name)+import Text.XML.Generator+import Numeric+import Utils+import Data.Vector as V ((!), length, last)++byNameId :: UShort -> TTF -> T.Text+byNameId id' ttf =+ str $ fromJust $ find predicate $ nameRecords $ name ttf+ where predicate nr =+ nameId nr == id'++fontFamilyName :: TTF -> T.Text+fontFamilyName = byNameId 1++svgDocType :: String+svgDocType = "<!DOCTYPE svg PUBLIC \"-//W3C//DTD SVG 1.1//EN\" \"http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd\" >"++svgDocInfo :: DocInfo+svgDocInfo = DocInfo { docInfo_standalone = False+ , docInfo_docType = Just svgDocType+ , docInfo_preMisc = xempty+ , docInfo_postMisc = xempty }+++advanceX :: Hmtx -> Int -> UFWord+advanceX hmtx' id' =+ advanceWidth hMetric+ where hMetrics' = hMetrics hmtx'+ hMetric | id' < V.length hMetrics' = hMetrics' ! id'+ | otherwise = V.last hMetrics'+++formatCoordinate :: Double -> String+formatCoordinate x+ | fromIntegral floored == x = show floored+ | otherwise = formatFloat 1 x+ where floored = floor x :: Int+ formatFloat precision a = showFFloat (Just precision) a ""++formatCoordinates :: Double -> Double -> String+formatCoordinates x y = formatCoordinate x ++ " " ++ formatCoordinate y++midval :: Double -> Double -> Double+midval a b = a + (b - a) / 2++toUpcase :: String -> String+toUpcase = map toUpper++shortestPath :: String -> [(String, String)] -> String+shortestPath command coordinates+ | Prelude.length relative < Prelude.length absolute = command ++ relative+ | otherwise = toUpcase command ++ absolute+ where relative = unwords (map fst coordinates)+ absolute = unwords (map snd coordinates)+++contourPath :: [(Double, Double, Int)] -> String+contourPath contour =+ "M" ++ formatCoordinates x' y' ++ path 0 ccontour x' y'+ where (x', y', _) = Prelude.head contour+ onCurve flag = testBit flag 0+ ccontour = cycle contour+ second = Prelude.head . tail+ third = Prelude.head . tail . tail+ path n ccontour' lastx lasty | n >= Prelude.length contour = "Z"+ | otherwise =+ let (x, y, f) = Prelude.head ccontour'+ (x1, y1, f1) = second ccontour'+ (x2, y2, f2) = third ccontour'+ showx x'' = (formatCoordinate (x'' - lastx), formatCoordinate x'')+ showy y'' = (formatCoordinate (y'' - lasty), formatCoordinate y'')+ showxy x'' y'' = (formatCoordinates (x'' - lastx) (y'' - lasty), formatCoordinates x'' y'')+ sp = shortestPath+ without i = path (n + i) (drop i ccontour')+ next True True _ | x == x1 = sp "v" [showy y1] ++ rest+ | y == y1 = sp "h" [showx x1] ++ rest+ | otherwise = sp "l" [showxy x1 y1] ++ rest+ where rest = without 1 x1 y1+ next True False True = sp "q" [showxy x1 y1, showxy x2 y2] ++ without 2 x2 y2+ next True False False = sp "q" [showxy x1 y1, showxy (midval x1 x2) (midval y1 y2)] ++ rest+ where rest = without 2 (midval x1 x2) (midval y1 y2)+ next False False _ = sp "t" [showxy (midval x x1) (midval y y1)] ++ rest+ where rest = without 1 (midval x x1) (midval y y1)+ next False True _ = sp "t" [showxy x1 y1] ++ rest+ where rest = without 1 x1 y1+ -- rest not implemented+ in+ next (onCurve f) (onCurve f1) (onCurve f2)+++glyphPoints :: Glyf -> TTF -> [[(Double, Double, Int)]]+glyphPoints EmptyGlyf _ = []+glyphPoints CompositeGlyf{cGlyfs = cglyfs} ttf =+ concatMap cglyhPoints cglyfs+ where+ cglyhPoints cg = map (map (transform cg)) (glyphPoints (glyf $ cGlyphIndex cg) ttf)+ glyf index = glyfs ttf ! fromIntegral index+ transform cg (x, y, flag) =+ ((x * cXScale cg + y * cScale10 cg) + fromIntegral (cXoffset cg)+ , (y * cYScale cg + x * cScale01 cg) + fromIntegral (cYoffset cg)+ , flag)++glyphPoints glyph _ =+ reverse bpts+ where endPts = map fromIntegral $ sEndPtsOfCountours glyph+ pts = zipWith3 (\x y f -> (fromIntegral x, fromIntegral y, fromIntegral f)) (sXCoordinates glyph) (sYCoordinates glyph) (sFlags glyph)+ splitPts (ac, offset', pts') x = (take (x - offset') pts' : ac, x, drop (x - offset') pts')+ (bpts, _, _) = foldl' splitPts ([], -1, pts) endPts+++svgPath :: Glyf -> TTF -> String+svgPath glyf ttf = foldl' (++) "" $ map contourPath (glyphPoints glyf ttf)+++escapeXMLChar :: Char -> String+escapeXMLChar '<' = "<"+escapeXMLChar '>' = ">"+escapeXMLChar '&' = "&"+escapeXMLChar '"' = """+escapeXMLChar '\'' = "'"+escapeXMLChar c | oc <= 0x7f && isPrint c = [c]+ | otherwise = "&#x" ++ showHex oc "" ++ ";"+ where oc = ord c++svgGlyph :: TTF -> CmapTable -> Int -> Int -> Xml Elem+svgGlyph ttf cmapTable averageAdvanceX code =+ xelem "glyph" (xattrs ([xattrRaw "unicode" (escapeXMLChar $ chr code)] +++ horizAdvanceXAttr +++ [xattrRaw "d" $ svgPath glyph ttf]))+ where glyphId' = glyphId cmapTable code+ glyph = glyfs ttf ! glyphId'+ horizAdvanceX = fromIntegral $ advanceX (hmtx ttf) glyphId'+ horizAdvanceXAttr | horizAdvanceX == averageAdvanceX = []+ | otherwise = [xattrRaw "horiz-adv-x" $ show horizAdvanceX]+++missingGlyph :: TTF -> Xml Elem+missingGlyph ttf =+ xelem "missing-glyph" (xattrs [xattr "horiz-adv-x" $ show $ advanceX (hmtx ttf) 0,+ xattr "d" $ svgPath glyph ttf])+ where glyph = glyfs ttf ! 0+++validCharCode :: Int -> Bool+validCharCode n | n == 0x9 = True+ | n == 0xA = True+ | n == 0xD = True+ | n >= 0x20 && n <= 0xD7FF = True+ | n >= 0xE000 && n <= 0xFFFD = True+ | n >= 0x1000 && n <= 0x10FFFF = True+ | otherwise = False++svgGlyphs :: TTF -> CmapTable -> (Xml Elem, Int)+svgGlyphs ttf cmapTable=+ (xelems $ missingGlyph ttf : map (svgGlyph ttf cmapTable averageAdvanceX) validGlyphCodes, averageAdvanceX)+ where codeRange = [(cmapStart cmapTable)..(cmapEnd cmapTable)]+ validGlyph code = validCharCode code && glyphId cmapTable code > 0+ validGlyphCodes = filter validGlyph codeRange+ averageAdvanceX = maxDuplicate $ map (fromIntegral . advanceX (hmtx ttf) . glyphId cmapTable) validGlyphCodes++fontFace :: TTF -> Xml Elem+fontFace ttf =+ xelem "font-face" (xattrs [xattr "font-family" $ fontFamilyName ttf,+ xattr "units-per-em" $ show . unitsPerEm $ TTF.head ttf,+ xattr "ascent" $ show . ascender $ hhea ttf,+ xattr "descent" $ show . descender $ hhea ttf])+++svgKern :: M.Map Int [Int] -> KernPair -> Xml Elem+svgKern glyphIdToCodeMap KernPair{kpLeft = left, kpRight = right,+ kpValue = value, kTCoverage = coverage} =+ xelem ktype (xattrs [xattrRaw "u1" $ unicode left,+ xattrRaw "u2" $ unicode right,+ xattr "k" $ show (-value)])+ where unicode code = intercalate "," $ map (escapeXMLChar . chr . fromIntegral) (glyphIdToCodeMap M.! fromIntegral code)+ ktype = if testBit coverage 0 then "hkern" else "vkern"++glyphIdToCode :: CmapTable -> M.Map Int [Int]+glyphIdToCode cmapTable =+ foldl build M.empty codeRange+ where codeRange = [(cmapStart cmapTable)..(cmapEnd cmapTable)]+ build m code | gid > 0 = M.alter (addCode code) gid m+ | otherwise = m+ where gid = glyphId cmapTable code+ addCode code Nothing = Just [code]+ addCode code (Just codes) = Just (code : codes)++svgKerns :: TTF -> CmapTable -> Bool -> [Xml Elem]+svgKerns _ _ False = []+svgKerns ttf cmapTable _ =+ map (svgKern $ glyphIdToCode cmapTable) allKernPairs+ where+ allKernPairs = filter validKernPair $ concatMap kernPairs $ kernTables $ kern ttf+ validKernPair KernPair{kpLeft = left, kpRight = right} =+ glyphId cmapTable (fromIntegral left) > 0 && glyphId cmapTable (fromIntegral right) > 0++testText :: TTF -> Xml Elem+testText ttf =+ xelem "g" (xattr "style" ("font-family: " ++ show (fontFamilyName ttf) ++ "; font-size:50;fill:black") <#>+ xelems (zipWith text ["!\"#$%&'()*+,-./0123456789:;å<>?",+ "@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_",+ "` abcdefghijklmnopqrstuvwxyz|{}~"] [1..]))+ where+ text :: String -> Int -> Xml Elem+ text t i = xelem "text" (xattrs [xattr "x" "20",+ xattr "y" $ show (i * 50)] <#> xtext t)++svgbody :: TTF -> CmapTable -> Bool -> Xml Elem+svgbody ttf cmapTable enableKern =+ xelems [xelemEmpty "metadata",+ xelem "defs" $+ xelem "font" (xattrs [xattr "horiz-adv-x" $ show avgAdvanceX] <#>+ xelems ([fontFace ttf,+ glyps] ++ svgKerns ttf cmapTable enableKern)),+ testText ttf]+ where (glyps, avgAdvanceX) = svgGlyphs ttf cmapTable++generate :: TTF -> B.ByteString -> CmapTable -> Bool -> B.ByteString+generate ttf _font cmapTable enableKern =+ xrender svg+ where+ svg = doc svgDocInfo $+ xelem "svg" (xattr "xmlns" "http://www.w3.org/2000/svg" <#> svgbody ttf cmapTable enableKern)
+ src/TTF.hs view
@@ -0,0 +1,583 @@+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+{-# LANGUAGE RecordWildCards #-}++module TTF(+ TTF(..)+ , Hhea(..)+ , Cmap(..)+ , CmapEncodingDirectory(..)+ , Glyf(..)+ , CompositeGlyfElement(..)+ , CmapTable(..)+ , KernPair(..)+ , Kern(..)+ , UFWord+ , UShort+ , ULong+ , Byte+ , parse+ , glyphId+ , cmapStart+ , cmapEnd+ , cmapTableFind+ , kernPairs+) where++import Control.Monad+import Data.Binary.Strict.Get+import Data.Bits+import qualified Data.ByteString as B+import Data.List+import Data.Map hiding(map, findIndex)+import Data.Maybe+import qualified Data.Vector as V+import Utils+import Font+++instance Font TTF where+ version = TTF.version+ numTables = TTF.numTables+ tableDirectories = TTF.tableDirectories+ os2panose = panose . os2+ os2fsSelection = fsSelection . os2+ os2usWeightClass = usWeightClass . os2+ os2ulUnicodeRange1 = ulUnicodeRange1 . os2+ os2ulUnicodeRange2 = ulUnicodeRange2 . os2+ os2ulUnicodeRange3 = ulUnicodeRange3 . os2+ os2ulUnicodeRange4 = ulUnicodeRange4 . os2+ os2ulCodePageRange1 = ulCodePageRange1 . os2+ os2ulCodePageRange2 = ulCodePageRange2 . os2+ headCheckSumAdjusment = checkSumAdjusment . TTF.head+ name = TTF.name+++data F12Group = F12Group { f12StartCharCode :: ULong+ , f12EndCharCode :: ULong+ , f12StartGlyphId :: ULong+ } deriving (Show)++data CmapTable = CmapFormat0 { c0Format :: UShort+ , c0Length :: UShort+ , c0Version :: UShort+ , c0GlyphIDs :: [Byte]+ } |+ CmapFormat4 { c4Format :: UShort+ , c4Length :: UShort+ , c4Language :: UShort+ , c4SegCountX2 :: UShort+ , c4SearchRange :: UShort+ , c4EntrySelector :: UShort+ , c4RangeShift :: UShort+ , c4EndCodes :: [UShort]+ , c4ReservedPad :: UShort+ , c4StartCodes :: [UShort]+ , c4IdDeltas :: [UShort]+ , c4IdRangeOffsets :: [UShort]+ , c4GlyphIds :: [UShort]+ } |+ CmapFormat6 { c6Format :: UShort+ , c6Length :: UShort+ , c6Version :: UShort+ , c6FirstCode :: UShort+ , c6EntryCount :: UShort+ , c6GlyphIds :: [UShort]+ } |+ CmapFormat12 { c12Format :: Fixed+ , c12Length :: ULong+ , c12Language :: ULong+ , c12NGroups :: ULong+ , c12Groups :: [F12Group]+ } deriving (Show)+++data CmapEncodingDirectory = CmapEncodingDirectory { cmapPlatformId :: UShort+ , cmapEncodingId :: UShort+ , cmapOffset :: ULong+ } deriving (Show)+++data Cmap = Cmap { cmapVersion :: UShort+ , numberOfSubtables :: UShort+ , encodingDirectories :: [CmapEncodingDirectory]+ , subTables :: [CmapTable]+ } deriving (Show)+++data Hhea = Hhea { hheaVersion :: Fixed+ , ascender :: FWord+ , descender :: FWord+ , lineGap :: FWord+ , advanceWidthMax :: UFWord+ , minLeftSideBearing :: FWord+ , minRightSideBearing :: FWord+ , xMaxExtend :: FWord+ , caretSlopeRise :: Short+ , caretSlopeRun :: Short+ -- reserved 5 Short+ , metricDataFormat :: Short+ , numberOfHMetrics :: UShort+ } deriving (Show)++data Maxp = Maxp { maxVersion :: Fixed+ , numGlyphs :: UShort+ , maxPoints :: UShort+ , maxContours :: UShort+ , maxCompositePoints :: UShort+ , maxCompositeContours :: UShort+ , maxZones :: UShort+ , maxTwilightPoints :: UShort+ , maxStorage :: UShort+ , maxFunctionDefs :: UShort+ , maxInstructionDefs :: UShort+ , maxStackElements :: UShort+ , maxSizeOfInstructions :: UShort+ , maxComponentElements :: UShort+ , maxComponentDepth :: UShort+ } deriving (Show)++++data Loca = Loca { locaOffsets :: [ULong] } deriving (Show)++data CompositeGlyfElement = CompositeGlyfElement {cFlags :: UShort+ , cGlyphIndex :: UShort+ , cXoffset :: Short+ , cYoffset :: Short+ , cArgument1 :: Short+ , cArgument2 :: Short+ , cXScale :: Double+ , cYScale :: Double+ , cScale01 :: Double+ , cScale10 :: Double+ } deriving (Show)++data Glyf = EmptyGlyf |+ SimpleGlyf { sNumberOfContours :: Short+ , sXMin :: FWord+ , sYMin :: FWord+ , sXMax :: FWord+ , sYMax :: FWord+ , sEndPtsOfCountours :: [UShort]+ , sInstructionLength :: UShort+ , sInstructions :: [Byte]+ , sFlags :: [Byte]+ , sXCoordinates :: [Short]+ , sYCoordinates :: [Short]+ } |+ CompositeGlyf { cNumberOfContours :: Short+ , cXMin :: FWord+ , cYMin :: FWord+ , cXMax :: FWord+ , cYMax :: FWord+ , cGlyfs :: [CompositeGlyfElement]+ , cNumInstruction :: UShort+ , cInstructions :: [Byte]+ } deriving (Show)++data KernPair = KernPair { kpLeft :: UShort+ , kpRight :: UShort+ , kpValue :: Short+ , kTCoverage :: UShort } deriving (Show)++data KernTable = KernSubTable0 { kNPairs :: UShort+ , kSearchRange :: UShort+ , kEntrySelector :: UShort+ , kRangeShift :: UShort+ , kKernPairs :: [KernPair] }+ | KernUnknown deriving (Show)++data Kern = Kern { kernVersion :: UShort+ , kernNumberOfSubtables :: UShort+ , kernTables :: [KernTable]+ } deriving (Show)++data TTF = TTF { version :: Fixed+ , numTables :: UShort+ , searchRange :: UShort+ , entrySelector :: UShort+ , rangeShift :: UShort+ , tableDirectories :: Map String TableDirectory+ , os2 :: OS2+ , head :: Head+ , hhea :: Hhea+ , name :: Name+ , cmap :: Cmap+ , maxp :: Maxp+ , loca :: Loca+ , hmtx :: Hmtx+ , glyfs :: V.Vector Glyf+ , kern :: Kern+ } deriving (Show)+++cmapTableFind :: TTF -> UShort -> UShort -> CmapTable+cmapTableFind ttf platformId' encodingId' =+ subTables (cmap ttf) !! index+ where directories = encodingDirectories $ cmap ttf+ index = fromJust $ findIndex predicate directories+ predicate dr = cmapPlatformId dr == platformId' &&+ cmapEncodingId dr == encodingId'+++cmapStart :: CmapTable -> Int+cmapStart CmapFormat0{c0GlyphIDs = glyphIds} = fromJust $ findIndex (> 0) glyphIds+cmapStart CmapFormat4{c4StartCodes = startCodes} = fromIntegral $ minimum startCodes+cmapStart CmapFormat6{c6FirstCode = firstCode} = fromIntegral firstCode+cmapStart CmapFormat12{c12Groups = groups} = fromIntegral $ f12StartCharCode $ Prelude.head groups++cmapEnd :: CmapTable -> Int+cmapEnd CmapFormat0{c0GlyphIDs = glyphIds} = last $ findIndices (> 0) glyphIds+cmapEnd CmapFormat4{c4EndCodes = endCodes} = fromIntegral $ maximum endCodes+cmapEnd CmapFormat6{c6FirstCode = firstCode,+ c6EntryCount = entryCount} = fromIntegral $ firstCode + entryCount+cmapEnd CmapFormat12{c12Groups = groups} = fromIntegral $ f12EndCharCode $ last groups+++glyphId :: CmapTable -> Int -> Int+glyphId CmapFormat0{c0GlyphIDs = glyphIds} n | n >= 0 && n < 256 = fromIntegral $ glyphIds !! n+ | otherwise = 0++glyphId CmapFormat4{c4EndCodes = endCodes+ , c4StartCodes = startCodes+ , c4IdDeltas = deltas+ , c4IdRangeOffsets = rangeOffsets+ , c4GlyphIds = glyphIds+ , c4SegCountX2 = segCountX2} n'+ | n < 0 || n > 0xFFFF = 0+ | (startCodes !! i) > n = 0+ | (rangeOffsets !! i) == 0 = fromIntegral ((deltas !! i) + n) `mod` 65536+ | otherwise = fromIntegral $ glyphIds !! (fromIntegral $ ((rangeOffsets !! i) `div` 2) + (n - startCodes !! i) - (segCount - fromIntegral i))+ where n = fromIntegral n'+ segCount = segCountX2 `div` 2+ i = fromIntegral . fromJust $ findIndex (>= n) endCodes++glyphId CmapFormat6{c6GlyphIds = glyphIds,+ c6FirstCode = firstCode,+ c6EntryCount = entryCount } n | n >= start && n < end = fromIntegral $ glyphIds !! (n - start)+ | otherwise = 0+ where start = fromIntegral firstCode+ end = start + fromIntegral entryCount+glyphId CmapFormat12{c12Groups = groups} n' | start <= n && (start /= -1) = glyphId'+ | otherwise = 0+ where+ n = fromIntegral n'+ mg = find ((>= n) . f12EndCharCode) groups+ g = fromJust mg+ start = fromMaybe (-1) (liftM f12StartCharCode mg)+ glyphId' = fromIntegral $ f12StartGlyphId g + (n - f12StartCharCode g)++kernPairs :: KernTable -> [KernPair]+kernPairs KernSubTable0{kKernPairs = pairs} = pairs+kernPairs KernUnknown = []++parseHhea :: Map String TableDirectory -> B.ByteString -> Hhea+parseHhea = parseTable "hhea" (do+ hheaVersion <- getFixed+ ascender <- getFWord+ descender <- getFWord+ lineGap <- getFWord+ advanceWidthMax <- getUFWord+ minLeftSideBearing <- getFWord+ minRightSideBearing <- getFWord+ xMaxExtend <- getFWord+ caretSlopeRise <- getShort+ caretSlopeRun <- getShort+ replicateM_ 5 getShort+ metricDataFormat <- getShort+ numberOfHMetrics <- getUShort+ return Hhea{..})++parseMaxp :: Map String TableDirectory -> B.ByteString -> Maxp+parseMaxp = parseTable "maxp" (do+ maxVersion <- getFixed+ numGlyphs <- getUShort+ maxPoints <- getUShort+ maxContours <- getUShort+ maxCompositePoints <- getUShort+ maxCompositeContours <- getUShort+ maxZones <- getUShort+ maxTwilightPoints <- getUShort+ maxStorage <- getUShort+ maxFunctionDefs <- getUShort+ maxInstructionDefs <- getUShort+ maxStackElements <- getUShort+ maxSizeOfInstructions <- getUShort+ maxComponentElements <- getUShort+ maxComponentDepth <- getUShort+ return Maxp{..})++parseKern :: Map String TableDirectory -> B.ByteString -> Kern+parseKern = parseTable "kern" (do+ kernVersion <- getUShort+ kernNumberOfSubtables <- getUShort+ kernTables <- replicateM (fromIntegral kernNumberOfSubtables) parseKernTable+ return Kern{..})++parseKernSubTable :: UShort -> Int -> Int -> Get KernTable+parseKernSubTable kTCoverage _ 0 = do+ kNPairs <- getUShort+ kSearchRange <- getUShort+ kEntrySelector <- getUShort+ kRangeShift <- getUShort+ kKernPairs <- replicateM (fromIntegral kNPairs) parseKernPair+ return KernSubTable0{..}+ where parseKernPair = do+ kpLeft <- getUShort+ kpRight <- getUShort+ kpValue <- getShort+ return KernPair{..}++parseKernSubTable _ length' _version = do+ skip (length' - 6)+ return KernUnknown++parseKernTable :: Get KernTable+parseKernTable = do+ kTLength <- getULong+ kTCoverage <- getUShort+ parseKernSubTable kTCoverage (fromIntegral kTLength) $ shiftR (fromIntegral kTCoverage) 8++parseHMetric :: Get HMetric+parseHMetric = do+ advanceWidth <- getUFWord+ lsb <- getFWord+ return HMetric{..}++parseHmtx :: Int -> Int -> Map String TableDirectory -> B.ByteString -> Hmtx+parseHmtx mcount glyphCount = parseTable "hmtx" (do+ hMetrics <- liftM V.fromList $ replicateM mcount parseHMetric+ leftSideBearings <- replicateM (glyphCount - mcount) getShort+ return Hmtx{..})++parseFlags :: Int -> [Byte] -> Get [Byte]+parseFlags n a | n <= 0 = return a+ | otherwise = do+ flag <- getByte+ if testBit flag 3 then+ do+ repeats <- liftM fromIntegral getByte+ parseFlags (n - repeats - 1) $ a ++ replicate repeats flag ++ [flag]+ else+ parseFlags (n - 1) $ a ++ [flag]++parseCoordinate ::+ Int -> Int -> (Short, [Short]) -> Byte -> Get (Short, [Short])+parseCoordinate shortBit sameBit (current, ac) flag+ | testBit flag shortBit = do+ delta <- liftM fromIntegral getByte+ return (if testBit flag sameBit then+ (current + delta, current + delta : ac)+ else+ (current - delta, current - delta : ac))+ | otherwise =+ if testBit flag sameBit then+ return (current, current : ac)+ else+ do+ delta <- getShort+ return (current + delta, current + delta : ac)+++parseCoordinates :: [Byte] -> Int -> Int -> Get [Short]+parseCoordinates flags shortBit sameBit =+ liftM (reverse . snd) $ foldM (parseCoordinate shortBit sameBit) (0, []) flags++parseCompositeGlyfElement :: Get CompositeGlyfElement+parseCompositeGlyfElement = do+ cFlags <- getUShort+ cGlyphIndex <- getUShort+ cArgument1 <- getArg cFlags+ cArgument2 <- getArg cFlags+ let cScale01 = 0.0+ cScale10 = 0.0+ cXScale = 1.0+ cYScale = 1.0+ cXoffset | testBit cFlags args_are_xy_values = cArgument1+ | otherwise = 0+ cYoffset | testBit cFlags args_are_xy_values = cArgument2+ | otherwise = 0+ if testBit cFlags we_have_a_scale then+ do+ cXScale <- liftM fromIntegral getUShort+ let cYScale = cXScale+ return CompositeGlyfElement{..}+ else if testBit cFlags we_have_an_x_and_y_scale then+ do+ cXScale <- getUFixed+ cYScale <- getUFixed+ return CompositeGlyfElement{..}+ else if testBit cFlags we_have_a_two_by_tow then+ do+ cXScale <- getUFixed+ cScale01 <- getUFixed+ cScale10 <- getUFixed+ cYScale <- getUFixed+ return CompositeGlyfElement{..}+ else return CompositeGlyfElement{..}+ where getArg f | testBit f arg_1_and_2_are_words = liftM fromIntegral getUShort+ | otherwise = liftM fromIntegral Font.getChar+ arg_1_and_2_are_words = 0+ args_are_xy_values = 1+ we_have_a_scale = 3+ we_have_an_x_and_y_scale = 6+ we_have_a_two_by_tow = 7++parseGlyf :: Short -> Get Glyf+parseGlyf numberOfContours | numberOfContours >= 0 = do+ sXMin <- getFWord+ sYMin <- getFWord+ sXMax <- getFWord+ sYMax <- getFWord+ sEndPtsOfCountours <- replicateM (fromIntegral numberOfContours) getUShort+ sInstructionLength <- getUShort+ sInstructions <- replicateM (fromIntegral sInstructionLength) getByte+ let count = if numberOfContours == 0 then 0 else fromIntegral $ last sEndPtsOfCountours + 1+ sFlags <- parseFlags count []+ sXCoordinates <- parseCoordinates sFlags 1 4+ sYCoordinates <- parseCoordinates sFlags 2 5+ return SimpleGlyf{sNumberOfContours = numberOfContours, ..}+ | otherwise = do+ cXMin <- getFWord+ cYMin <- getFWord+ cXMax <- getFWord+ cYMax <- getFWord+ cGlyfs <- parseElements+ let lastFlag = cFlags $ last cGlyfs+ cNumInstruction = 0+ cInstructions = []+ if testBit lastFlag we_have_instructions then+ do+ cNumInstruction <- getUShort+ cInstructions <- replicateM (fromIntegral cNumInstruction) getByte+ return CompositeGlyf{cNumberOfContours = numberOfContours, ..}+ else return CompositeGlyf{cNumberOfContours = numberOfContours, ..}+ where+ parseElements = do+ cge <- parseCompositeGlyfElement+ if testBit (cFlags cge) more_components then+ do+ rest <- parseElements+ return $ cge : rest+ else+ return [cge]+ more_components = 5+ we_have_instructions = 8++++parseGlyfs :: Int -> [Int] -> Map String TableDirectory -> B.ByteString -> [Glyf]+parseGlyfs glyphCount offsets tds font =+ zipWith getGlyph (take glyphCount offsets) $ diff offsets+ where tableStart = fromIntegral . tDOffset $ tds ! "glyf"+ getGlyph _ 0 = EmptyGlyf+ getGlyph offset _len =+ fromRight $ runGet (do+ skip $ tableStart + offset+ numberOfContours <- getShort+ parseGlyf numberOfContours+ ) font++parseLoca :: Int -> Int -> Map String TableDirectory -> B.ByteString -> Loca+parseLoca 0 count = parseTable "loca" (do+ locaOffsets <- replicateM (count + 1) (liftM ((*) 2 . fromIntegral) getUShort)+ return Loca{..})+parseLoca 1 count = parseTable "loca" (do+ locaOffsets <- replicateM (count + 1) getULong+ return Loca{..})+parseLoca _ _ = error "error while parsing loca table"++parseCmapEncodingDirectory :: Get CmapEncodingDirectory+parseCmapEncodingDirectory = do+ cmapPlatformId <- getUShort+ cmapEncodingId <- getUShort+ cmapOffset <- getULong+ return CmapEncodingDirectory{..}+++parseCmapSubTable :: Int -> Get CmapTable+parseCmapSubTable 4 = do+ c4Length <- getUShort+ c4Language <- getUShort+ c4SegCountX2 <- getUShort+ let segCount = fromIntegral c4SegCountX2 `div` 2+ c4SearchRange <- getUShort+ c4EntrySelector <- getUShort+ c4RangeShift <- getUShort+ c4EndCodes <- replicateM segCount getUShort+ c4ReservedPad <- getUShort+ c4StartCodes <- replicateM segCount getUShort+ c4IdDeltas <- replicateM segCount getUShort+ c4IdRangeOffsets <- replicateM segCount getUShort+ let glyphCount = (fromIntegral c4Length - (2 * 8) - (2 * segCount * 4)) `div` 2+ c4GlyphIds <- replicateM glyphCount getUShort+ return CmapFormat4{c4Format = 4, ..}++parseCmapSubTable 0 = do+ c0Length <- getUShort+ c0Version <- getUShort+ c0GlyphIDs <- replicateM 256 getByte+ return CmapFormat0{c0Format = 0, ..}++parseCmapSubTable 6 = do+ c6Length <- getUShort+ c6Version <- getUShort+ c6FirstCode <- getUShort+ c6EntryCount <- getUShort+ c6GlyphIds <- replicateM (fromIntegral c6EntryCount) getUShort+ return CmapFormat6{c6Format = 6, ..}++parseCmapSubTable 12 = do+ _ <- getUShort+ c12Length <- getULong+ c12Language <- getULong+ c12NGroups <- getULong+ c12Groups <- replicateM (fromIntegral c12NGroups) parseF12Group+ return CmapFormat12{c12Format = 12, ..}+ where parseF12Group = do+ f12StartCharCode <- getULong+ f12EndCharCode <- getULong+ f12StartGlyphId <- getULong+ return F12Group{..}++parseCmapSubTable n = error $ "subtable format not implemented " ++ show n++parseCmapEncoding :: B.ByteString -> Int -> CmapTable+parseCmapEncoding font offset =+ fromRight $ runGet (do+ skip offset+ format <- getUShort+ parseCmapSubTable $ fromIntegral format) font++parseCmap :: Map String TableDirectory -> B.ByteString -> Cmap+parseCmap tds font =+ fromRight $ runGet (do+ let tableStart = fromIntegral $ tDOffset $ tds ! "cmap"+ skip tableStart+ cmapVersion <- getUShort+ numberOfSubtables <- getUShort+ encodingDirectories <- replicateM (fromIntegral numberOfSubtables) parseCmapEncodingDirectory+ let subTables = map (parseCmapEncoding font . (+ tableStart) . fromIntegral . cmapOffset) encodingDirectories+ return Cmap{..}) font++parse :: B.ByteString -> Get TTF+parse font = do+ version <- getFixed+ numTables <- getUShort+ searchRange <- getUShort+ entrySelector <- getUShort+ rangeShift <- getUShort+ tableDirectories <- parseTableDirectories font (fromIntegral numTables)+ let os2 = parseOS2 tableDirectories font+ head = parseHead tableDirectories font+ hhea = parseHhea tableDirectories font+ name = parseName tableDirectories font+ cmap = parseCmap tableDirectories font+ maxp = parseMaxp tableDirectories font+ kern = parseKern tableDirectories font+ glyphCount = (fromIntegral $ numGlyphs maxp)+ loca = parseLoca (fromIntegral $ indexToLocFormat head) glyphCount tableDirectories font+ hmtx = parseHmtx (fromIntegral $ numberOfHMetrics hhea) glyphCount tableDirectories font+ glyfs = V.fromList $ parseGlyfs glyphCount (map fromIntegral $ locaOffsets loca) tableDirectories font+ in+ return TTF{..}
+ src/Utils.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE RecordWildCards #-}+module Utils(+ fromRight+ , substr+ , toStrict+ , toLazy+ , diff+ , debug+ , formatTable+ , maxDuplicate+) where++import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import Control.Monad+import Debug.Trace+import Data.List+import Text.Printf+import Data.Function++fromRight :: (Either String t2, t) -> t2+fromRight (Right x, _) = x+fromRight (Left y, _) = error y++substr :: Int -> Int -> B.ByteString -> B.ByteString+substr s l = B.take l . B.drop s++toStrict :: BL.ByteString -> B.ByteString+toStrict = B.concat . BL.toChunks++toLazy :: B.ByteString -> BL.ByteString+toLazy str = BL.fromChunks [str]++diff :: Num b => [b] -> [b]+diff l = zipWith (-) l $ tail l++formatTable :: [[String]] -> String+formatTable table =+ line ++ unlines (map formatRow table) ++ line+ where maxSize = map maximum $ transpose $ map (map length) table+ line = concat (replicate (sum maxSize + (length maxSize - 1) * 3) "-") ++ "\n"+ formatRow row = intercalate " | " $ zipWith formatCell row maxSize+ formatCell :: String -> Int -> String+ formatCell field size = printf ("%-" ++ show size ++ "s") field++maxDuplicate :: [Int] -> Int+maxDuplicate = head . minimumBy (compare `on` (negate . length)) . group . sort++debug :: Monad m => String -> m ()+debug str =+ when True $ trace str $ return ()
+ src/WOFF.hs view
@@ -0,0 +1,98 @@+module WOFF(+ generate+) where++import qualified Codec.Compression.Hopfli as Hopfli+import qualified Codec.Compression.Zlib as Zlib+import Control.Monad+import Data.Binary.Put+import qualified Data.ByteString as B+import Data.ByteString.Char8 (pack)+import Data.Function+import Data.List+import qualified Data.Map as Map+import Data.Word+import Font+import Utils+++type UInt32 = Word32+type UInt16 = Word16++putUInt32 :: UInt32 -> Put+putUInt32 = putWord32be++putUInt16 :: UInt16 -> Put+putUInt16 = putWord16be++putTableDirectory ::+ ((Int, Int, Int, B.ByteString), TableDirectory) -> PutM ()+putTableDirectory ((startOffset, size, _padding, _compressedData), directory) = do+ putByteString $ pack $ tDTag directory+ putUInt32 $ fromIntegral startOffset+ putUInt32 $ fromIntegral size+ putUInt32 $ fromIntegral $ tDLength directory+ putUInt32 $ tDCheckSum directory+++type Compressor = B.ByteString -> B.ByteString++getCompressor :: Bool -> Compressor+getCompressor False = toStrict . Zlib.compress . toLazy+getCompressor True = Hopfli.compress++calculateOffset ::+ Compressor ->+ [(Int, Int, Int, B.ByteString)] -> B.ByteString+ -> [(Int, Int, Int, B.ByteString)]+calculateOffset compressor offsets raw =+ (start, size, padding, compressedData) : offsets+ where originalSize = B.length raw+ compressed = compressor raw+ compressedSize = B.length compressed+ compressedData | originalSize <= compressedSize = raw+ | otherwise = compressed+ size = min originalSize compressedSize+ (lastStart, lastSize, lastPadding, _) = head offsets+ start = lastStart + lastSize + lastPadding+ padding | (size `mod` 4) == 0 = 0+ | otherwise = 4 - (size `mod` 4)++putFontData :: (Int, Int, Int, B.ByteString) -> PutM ()+putFontData (_, _, padding, compressedData) = do+ putByteString compressedData+ replicateM_ padding (putWord8 0x0)++payload :: Font f => f -> B.ByteString -> Bool -> Put+payload font rawFont enableZopfli = do+ putUInt16 $ numTables font+ putUInt16 0 -- reserved+ putUInt32 $ fromIntegral $ B.length rawFont+ putUInt16 1 -- woff version major+ putUInt16 0 -- woff version minor+ putUInt32 0 -- meta offset+ putUInt32 0 -- meta length+ putUInt32 0 -- meta length uncompressed+ putUInt32 0 -- private block offset+ putUInt32 0 -- private block length+ let tds = Map.elems $ tableDirectories font+ sortByOffset = sortBy (compare `on` tDOffset)+ sortedByTag = sortBy (compare `on` tDTag . snd)+ initialOffset = [(fromIntegral (44 + (20 * numTables font)), 0, 0, pack "")]+ offsets = drop 1 $ reverse $+ foldl (calculateOffset $ getCompressor enableZopfli) initialOffset (map tDRawData $ sortByOffset tds)+ mapM_ putTableDirectory $ sortedByTag $ zip offsets (sortByOffset tds)+ mapM_ putFontData offsets+++combine :: Font f => f -> B.ByteString -> PutM ()+combine font rest = do+ putUInt32 0x774F4646+ putUInt32 $ version font+ putUInt32 $ fromIntegral $ B.length rest + 12+ putByteString rest++generate :: Font f => f -> B.ByteString -> Bool -> B.ByteString+generate font rawFont enableZopfli =+ let rest = toStrict $ runPut (payload font rawFont enableZopfli)+ in toStrict $ runPut $ combine font rest
src/Webify.hs view
@@ -121,7 +121,7 @@ displayError :: FilePath -> SomeException -> IO () displayError file e = (putStrLn $ "Failed to convert " ++ file) >> (putStrLn $ show e) -webifyVersion = "0.1.5.0"+webifyVersion = "0.1.6.0" main :: IO () main = do
webify.cabal view
@@ -1,5 +1,5 @@ name: webify-version: 0.1.5.0+version: 0.1.6.0 synopsis: webfont generator description: A command line tool to convert ttf file to woff, eot & svg files@@ -20,11 +20,11 @@ executable webify hs-source-dirs: src main-is: Webify.hs+ other-modules: EOT, Font, OTF, SVG, TTF, Utils, WOFF if flag(debug) ghc-prof-options: -prof, -fprof-auto - -- other-modules: build-depends: base ==4.6.*, containers >= 0.4.2.1, bytestring >= 0.9,