opentype (empty) → 0.0.1
raw patch · 15 files changed
+2308/−0 lines, 15 filesdep +basedep +binarydep +bytestringsetup-changed
Dependencies added: base, binary, bytestring, containers, ghc, pretty-hex, time, vector
Files
- LICENSE +21/−0
- Opentype/Fileformat.hs +281/−0
- Opentype/Fileformat/Cmap.hs +524/−0
- Opentype/Fileformat/Glyph.hs +534/−0
- Opentype/Fileformat/Head.hs +186/−0
- Opentype/Fileformat/Hhea.hs +61/−0
- Opentype/Fileformat/Kern.hs +69/−0
- Opentype/Fileformat/Maxp.hs +72/−0
- Opentype/Fileformat/Name.hs +95/−0
- Opentype/Fileformat/OS2.hs +150/−0
- Opentype/Fileformat/Post.hs +135/−0
- Opentype/Fileformat/Types.hs +127/−0
- Setup.lhs +6/−0
- opentype.cabal +46/−0
- tests/test.hs +1/−0
+ LICENSE view
@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2016 Kristof Bastiaensen++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ Opentype/Fileformat.hs view
@@ -0,0 +1,281 @@+{-# LANGUAGE TupleSections #-}++-- | This module provides opentype file loading and writing. An+-- attempt was made to have a higher level interface without+-- sacrificing features of the file format.++module Opentype.Fileformat+ (-- * Types+ ShortFrac (..), Fixed, FWord, UFWord, GlyphID,+ -- * Main datatype+ OpentypeFont (..), maxpTable, glyfTable, OutlineTables (..), GenericTables,+ -- * IO+ readOTFile, writeOTFile,+ -- * Head table+ HeadTable(..),+ -- * Glyf table+ GlyfTable(..), Glyph(..), GlyphOutlines(..),+ CurvePoint(..), Instructions, GlyphComponent(..),+ -- * CMap table+ CmapTable(..), CMap(..), PlatformID(..), MapFormat (..),+ -- * Hhea table+ HheaTable(..),+ -- * Maxp table+ MaxpTable(..),+ -- * Name table+ NameTable(..), NameRecord(..),+ -- * Post table+ PostTable(..), PostVersion(..),+ -- * OS/2 table+ OS2Table(..),+ -- * Kern table+ KernTable(..), KernPair(..)+ ) where+import Opentype.Fileformat.Types+import Opentype.Fileformat.Head+import Opentype.Fileformat.Glyph+import Opentype.Fileformat.Hhea+import Opentype.Fileformat.Cmap+import Opentype.Fileformat.Maxp+import Opentype.Fileformat.Name+import Opentype.Fileformat.Post+import Opentype.Fileformat.Kern+import Opentype.Fileformat.OS2+import Data.Binary.Get+import Data.Binary.Put+import Data.Binary+import Data.Maybe+import Data.Bits+import Data.List (zip4, sort)+import Data.Char+import Data.Foldable+import Control.Monad+import qualified Data.ByteString.Lazy as Lazy+import qualified Data.ByteString as Strict+import Data.ByteString.Unsafe+import qualified Data.Map as M++type GenericTables = M.Map String Lazy.ByteString++-- | truetype or opentype font+data OpentypeFont = OpentypeFont {+ -- | Use apple scaler. Should not be used for opentype fonts.+ appleScaler :: Bool,+ -- | global information about the font. + headTable :: HeadTable,+ -- | global horizontal metrics information+ hheaTable :: HheaTable,+ -- | mapping of character codes to the glyph index values+ cmapTable :: CmapTable,+ -- | information strings in different languages+ nameTable :: NameTable,+ -- | data for postscript printers+ postTable :: PostTable,+ -- | windows specific information+ os2Table :: Maybe OS2Table,+ -- | Kerning tables+ kernTable :: Maybe KernTable,+ -- | tables specific to the outline type (cubic or quadratic).+ outlineTables :: OutlineTables,+ -- | not (yet) supported tables+ otherTables :: GenericTables+ }+ deriving Show++-- | tables for quadratic outlines (truetype or opentype)+data OutlineTables =+ QuadTables MaxpTable GlyfTable |+ CubicTables + deriving Show++maxpTable :: OpentypeFont -> Maybe MaxpTable+maxpTable font = case outlineTables font of+ QuadTables m _ -> Just m+ _ -> Nothing++glyfTable :: OpentypeFont -> Maybe GlyfTable+glyfTable font = case outlineTables font of+ QuadTables _ g -> Just g+ _ -> Nothing++data ScalerType =+ -- opentype with cff+ CubicScaler |+ -- truetype and opentype with glyf+ QuadScaler |+ -- apple only scaler+ AppleScaler+ deriving Eq+ +type SfntLocs = M.Map Scaler (Word32, Word32)+type Scaler = Word32++-- | write an opentype font to a file+writeOTFile :: OpentypeFont -> FilePath -> IO ()+writeOTFile font file = + case outlineTables font of+ CubicTables ->+ error "cubic splines are not yet supported"+ QuadTables maxpTbl (GlyfTable glyphs) ->+ let (lengths, glyphBs) = runPutM $ writeGlyphs glyphs+ (format, locaBs) = runPutM $ writeLoca lengths+ (longHor, hmtxBs) = runPutM $ writeHmtx glyphs+ head2 = updateHead glyphs $+ (headTable font) {+ headVersion = 0x00010000,+ fontDirectionHint = 2,+ longLocIndices = format }+ hhea2 = updateHhea glyphs $+ (hheaTable font) {numOfLongHorMetrics = fromIntegral longHor}+ maxp2 = updateMaxp glyphs $+ maxpTbl {maxpVersion = 0x00010000}+ headBs = Lazy.toStrict $ runPut $ putHeadTable head2+ cmapBs = Lazy.toStrict $ runPut $ putCmapTable $ cmapTable font+ hheaBs = Lazy.toStrict $ runPut $ putHheaTable hhea2+ maxpBs = Lazy.toStrict $ runPut $ putMaxpTable maxp2 + nameBs = Lazy.toStrict $ runPut $ putNameTable $ nameTable font+ postBs = Lazy.toStrict $ runPut $ putPostTable $ postTable font+ os2Bs = (Lazy.toStrict . runPut . putOS2Table) <$> os2Table font+ kernBs = (Lazy.toStrict . runPut . putKernTable) <$> kernTable font+ scaler | appleScaler font = AppleScaler + | otherwise = QuadScaler+ in Lazy.writeFile file $ runPut $ + writeTables scaler $ concat + [[(nameToInt "head", headBs),+ (nameToInt "hhea", hheaBs),+ (nameToInt "maxp", maxpBs)],+ maybeToList $ (nameToInt "OS/2",) <$> os2Bs,+ [(nameToInt "hmtx", Lazy.toStrict hmtxBs),+ (nameToInt "cmap", cmapBs),+ (nameToInt "loca", Lazy.toStrict locaBs),+ (nameToInt "glyf", Lazy.toStrict glyphBs)],+ maybeToList $ (nameToInt "kern",) <$> kernBs,+ [(nameToInt "name", nameBs),+ (nameToInt "post", postBs)]]+ ++runGetOrErr :: Get b -> Lazy.ByteString -> Either String b+runGetOrErr g bs = case runGetOrFail g bs of+ Left (_, _, str) -> Left str+ Right (_, _, res) -> Right res++-- | read an opentype font from a file. +readOTFile :: FilePath -> IO OpentypeFont+readOTFile file = do+ strict <- Strict.readFile file+ let res = do+ (locs, scaler) <- runGetOrErr readTables $+ Lazy.fromStrict strict+ let readTable tag = case M.lookup (nameToInt tag) locs of+ Nothing -> Left $ "Table " ++ tag ++ " not found."+ Just (offset, _) ->+ Right $ Strict.drop (fromIntegral offset) strict+ readLazy tag = Lazy.fromStrict <$> readTable tag+ readMaybe tag = case M.lookup (nameToInt tag) locs of+ Nothing -> Right Nothing+ Just (offset, _) ->+ Right $ Just $ Lazy.fromStrict $ Strict.drop (fromIntegral offset) strict+ headBs <- runGetOrErr getHeadTable =<< readLazy "head"+ maxpTbl <- runGetOrErr getMaxpTable =<< readLazy "maxp"+ hheaTbl <- runGetOrErr getHheaTable =<< readLazy "hhea"+ offsets <- runGetOrErr (readGlyphLocs (longLocIndices headBs)+ (fromIntegral $ numGlyphs maxpTbl)) =<<+ readLazy "loca"+ hmetrics <- runGetOrErr (readHmetrics (fromIntegral $ numOfLongHorMetrics hheaTbl)+ (fromIntegral $ numGlyphs maxpTbl))+ =<< readLazy "hmtx"+ glyphTbl <- readGlyphTable (zip offsets (zipWith (-) offsets (tail offsets)))+ hmetrics =<< readTable "glyf"+ postTbl <- runGetOrErr getPostTable =<< readLazy "post"+ nameTbl <- readNameTable =<< readTable "name"+ cmapTbl <- readCmapTable =<< readTable "cmap"+ os2tbl <- traverse (runGetOrErr getOS2Table) =<< readMaybe "OS/2"+ kerntbl <- traverse (runGetOrErr getKernTable) =<< readMaybe "kern"+ return $ OpentypeFont (scaler == AppleScaler) headBs hheaTbl+ cmapTbl nameTbl postTbl os2tbl kerntbl+ (QuadTables maxpTbl (GlyfTable glyphTbl)) M.empty+ either (ioError.userError) return res+ +nameToInt :: String -> Word32+nameToInt string =+ fromIntegral $ sum $ zipWith (\c b -> ord c `shift` b) string [24, 16..0]++readTables :: Get (SfntLocs, ScalerType)+readTables = do+ scaler <- getWord32be+ scalerType <- case scaler of+ 0x74727565 -> return AppleScaler+ 0x4F54544F -> return CubicScaler+ 0x00010000 -> return QuadScaler+ _ -> fail "This file is not a truetype or opentype file."+ numTables <- getWord16be+ skip 6+ locs <- fmap M.fromAscList $+ replicateM (fromIntegral numTables) $+ do tag <- getWord32be+ _ <- getWord32be+ offset <- getWord32be+ size <- getWord32be+ return (tag, (offset, size))+ return (locs, scalerType)++checkSum :: Strict.ByteString -> Word32+checkSum bs+ | Strict.length bs < 4 =+ sum [fromIntegral n `shift` l | (n, l) <- zip (Strict.unpack bs) [24, 16, 8, 0]]+ | otherwise =+ fromIntegral (unsafeIndex bs 0) `shift` 24 ++ fromIntegral (unsafeIndex bs 1) `shift` 16 ++ fromIntegral (unsafeIndex bs 2) `shift` 8 ++ fromIntegral (unsafeIndex bs 3) ++ checkSum (Strict.drop 4 bs)++headWithChecksum :: Strict.ByteString -> Word32 -> Put+headWithChecksum bs cksum = do+ putByteString $ Strict.take 8 bs+ putWord32be $ 0xB1B0AFBA - cksum+ putByteString $ Strict.drop 12 bs+ +putPadding :: Strict.ByteString -> Put+putPadding bs = replicateM_ (pad-sz) (putInt8 0)+ where sz = fromIntegral $ Strict.length bs+ pad = padded sz+ +padded :: (Bits a, Num a) => a -> a+padded len = (len+3) .&. complement 3++writeTables :: ScalerType -> [(Word32, Strict.ByteString)] -> Put+writeTables scaler tables = do+ putByteString unChecked+ let cksumTot = fromIntegral $ sum $ checkSum unChecked:ckSums+ for_ (zip tables tableBs) $+ \((tag,_), bs) -> + if tag == nameToInt "head"+ then do headWithChecksum bs cksumTot+ putPadding bs+ else do putByteString bs+ putPadding bs+ where+ entrySelector, searchRange, nTables :: Word16+ nTables = fromIntegral $ length tables+ entrySelector = fromIntegral $ iLog2 nTables+ searchRange = 1 `shift` (fromIntegral entrySelector+4)+ offsets = scanl (+) (fromIntegral $ 16*length tables + 12) (map padded lengths)+ lengths = map Strict.length tableBs+ tableBs = map snd tables+ ckSums = map checkSum tableBs+ unChecked = Lazy.toStrict $ runPut $ do+ putWord32be $ case scaler of+ AppleScaler -> nameToInt "true"+ CubicScaler -> nameToInt "OTTO"+ QuadScaler -> 0x00010000+ putWord16be $ fromIntegral nTables+ putWord16be searchRange+ putWord16be entrySelector+ putWord16be $ nTables * 16 - searchRange+ for_ (sort $ zip4 tables ckSums offsets lengths) $+ \((tag,_), cksum, offset, len) -> do+ putWord32be tag+ putWord32be cksum+ putWord32be $ fromIntegral offset+ putWord32be $ fromIntegral len
+ Opentype/Fileformat/Cmap.hs view
@@ -0,0 +1,524 @@+module Opentype.Fileformat.Cmap where+import Opentype.Fileformat.Types+import Data.Binary+import Data.Binary.Put+import Data.List (sort, mapAccumL, foldl')+import Data.Either (either)+import Control.Monad+import Data.Traversable (for)+import Data.Foldable (for_, traverse_)+import qualified Data.ByteString.Lazy as Lazy+import qualified Data.ByteString as Strict+import qualified Data.Map as M+import qualified Data.IntSet as IS+import Data.Maybe+import Data.Bits+import Data.Int+-- import Hexdump -- for debugging++-- | This table defines the mapping of character codes to the glyph+-- index values used in the font. It may contain more than one+-- subtable, in order to support more than one character encoding+-- scheme. Character codes that do not correspond to any glyph in the+-- font should be mapped to glyph index 0. The glyph at this location+-- must be a special glyph representing a missing character, commonly+-- known as .notdef.+--+-- The table header indicates the character encodings for which+-- subtables are present. Each subtable is in one of seven possible+-- formats and begins with a format code indicating the format+-- used.+-- +-- The `platformID` and platform-specific `encodingID` in the header+-- entry (and, in the case of the Macintosh platform, the `macLanguage`+-- field in the subtable itself) are used to specify a particular+-- cmap encoding. Each platform ID, platform-specific encoding ID,+-- and subtable `macLanguage` combination may appear only once in the+-- `CmapTable`.+--+-- When `platformID` is `UnicodePlatform`, `encodingID` is interpreted as follows:+-- +-- * 0: Default semantics+-- * 1: Version 1.1 semantics+-- * 2: ISO 10646 1993 semantics (deprecated)+-- * 3: Unicode 2.0 or later semantics (BMP only)+-- * 4: Unicode 2.0 or later semantics (non-BMP characters allowed)+-- * 5: Unicode Variation Sequences+-- * 6: Full Unicode coverage (used with type 13.0 cmaps by OpenType)+--+-- When `platformID` `MacintoshPlatform`, the `encodingID` is a QuickDraw script code.+-- +-- Note that the use of the Macintosh platformID is currently+-- discouraged. Subtables with a Macintosh platformID are only+-- required for backwards compatibility with QuickDraw and will be+-- synthesized from Unicode-based subtables if ever needed.+--+-- When `platformID` is `MicrosoftPlatform`, the `encodingID` is a is interpreted as follows:+--+-- * 0: Symbol+-- * 1: Unicode BMP-only (UCS-2)+-- * 2: Shift-JIS+-- * 3: PRC+-- * 4: BigFive+-- * 5: Johab+-- * 10: Unicode UCS-4++data CmapTable = CmapTable [CMap]+ deriving Show++data CMap = CMap {+ cmapPlatform :: PlatformID,+ cmapEncoding :: Word16,+ -- | used only in the Macintosh platformID (/DEPRECATED/)+ cmapLanguage :: Word16,+ -- | internal format of the map+ mapFormat :: MapFormat,+ -- | set contains high byte\/word if part of multibyte\/word+ -- character.+ multiByte :: IS.IntSet,+ -- | map from character code to glyph index+ glyphMap :: WordMap GlyphID+ }+ deriving Show++instance Ord CMap where+ compare (CMap pfID encID lang _ _ _) (CMap pfID2 encID2 lang2 _ _ _) =+ compare (pfID, encID, lang) (pfID2, encID2, lang2)++instance Eq CMap where+ (CMap pfID encID lang _ _ _) == (CMap pfID2 encID2 lang2 _ _ _) =+ (pfID, encID, lang) == (pfID2, encID2, lang2)++data MapFormat = + -- | 8 bit encoding, contiguous block of bytes. /LEGACY ONLY./+ MapFormat0 |+ -- | mixed 8\/16 bit encoding with gaps. /LEGACY ONLY./+ MapFormat2 |+ -- | 16 bit encoding with holes. This should contain the BMP for a+ -- unicode font.+ MapFormat4 |+ -- | 16 bit single contiguous block (trimmed).+ MapFormat6 |+ -- | mixed 16\/32 bit, for compatibility only, /DO NOT USE/+ MapFormat8 |+ -- | 32 bit single contiguous block (trimmed), for compatibility+ -- only, /DO NOT USE/+ MapFormat10 |+ -- | 32 bit segmented coverage. This should contain Unicode+ -- encodings with glyphs above 0xFFFF. It's recommended to save a+ -- subset to format 4, for backwards compatibility.+ MapFormat12+ deriving Show++putCmapTable :: CmapTable -> Put+putCmapTable (CmapTable cmaps_) =+ do putWord16be 0+ putWord16be $ fromIntegral $ length cmaps+ for_ (zip offsets cmaps) $+ \(offset, CMap pfID encID _ _ _ _) ->+ do putPf pfID+ putWord16be encID+ putWord32be offset+ traverse_ putLazyByteString cmapsBs+ where+ cmaps = sort cmaps_+ offsets :: [Word32]+ offsets =+ scanl (+) (fromIntegral $ 4 + 8 * length cmaps) $+ map (fromIntegral . Lazy.length) cmapsBs+ cmapsBs = map (runPut.putCmap) cmaps++readCmapTable :: Strict.ByteString -> Either String CmapTable+readCmapTable bs = do+ version <- index16 bs 0+ when (version /= 0) $+ fail "unsupported cmap version."+ n <- index16 bs 1+ entries <- for [0..n-1] $ \i -> do+ pfID <- toPf =<< (index16 bs $ 2 + i*4)+ encID <- index16 bs $ 2 + i*4 + 1+ offset <- index32 bs $ 2 + fromIntegral i*2+ return (offset, pfID, encID)+ cmaps <- for entries $ \(offset, pfID, encID) -> do+ cm <- readCmap $ Strict.drop (fromIntegral offset) bs+ Right $ cm {cmapPlatform = pfID, cmapEncoding = encID}+ return $ CmapTable cmaps++putCmap :: CMap -> Put+putCmap cmap = case mapFormat cmap of+ MapFormat0 -> putMap0 cmap+ MapFormat2 -> putMap2 cmap+ -- 16 bit encoding with holes+ MapFormat4 -> putMap4 cmap+ -- trimmed 16 bit mapping.+ MapFormat6 -> putMap6 cmap+ -- mixed 16/32 bit encoding (/DEPRECATED/)+ MapFormat8 -> putMap8 cmap+ MapFormat10 -> putMap10 cmap+ -- 32 bit segmented coverage+ MapFormat12 -> putMap12 cmap++readCmap :: Strict.ByteString -> Either String CMap+readCmap bs_ = do+ c <- index16 bs_ 0+ let bs | (c >= 8 && c < 14) = Strict.drop 8 bs_+ | otherwise = Strict.drop 4 bs_+ either fail return $+ case c of + 0 -> getMap0 bs+ 2 -> getMap2 bs+ 4 -> getMap4 bs+ 6 -> getMap6 bs+ 8 -> getMap8 bs+ 10 -> getMap10 bs+ 12 -> getMap12 bs+ i -> fail $ "unsupported map encoding " ++ show i++subIntMap :: Word32 -> Word32 -> WordMap GlyphID -> WordMap GlyphID+subIntMap from to intMap =+ fst $ M.split (fromIntegral to+1) $ snd $+ M.split (fromIntegral from-1) intMap++asSubtypeFrom :: b -> [(a, b)] -> b+asSubtypeFrom a _ = a++-- Put codes in range, and use zero glyph when no code is found.+putCodes :: Word32 -> Word32 -> [(Word32, GlyphID)] -> Put+putCodes start end _+ | start > end = return ()++putCodes start end [] = do+ putWord16be 0+ putCodes (start+1) end []+ +putCodes start end l@((i, code):rest)+ | start < i = do putWord16be 0+ putCodes (start+1) end l+ | otherwise = do putWord16be code+ putCodes (i+1) end rest++-- write subcodes as range, with zero glyph for missing codes.+subCodes :: WordMap GlyphID -> Word32 -> Word32 -> Put+subCodes set start end =+ putCodes start end $ M.toList $ subIntMap start end set++data SubTable2 = SubTable2 {+ highByte :: Word16,+ firstCode :: Word16,+ entryCount :: Word16,+ rangeOffset :: Word16,+ rangeBytes :: Put+ }++putMap0 :: CMap -> PutM ()+putMap0 cmap = do+ putWord16be 0+ putWord16be 262+ putWord16be $ cmapLanguage cmap+ let gm = glyphMap cmap+ for_ [0..255] $ \c ->+ putWord8 $ fromIntegral $+ fromMaybe 0 (M.lookup c gm)++getMap0 :: Strict.ByteString -> Either String CMap+getMap0 bs =+ if Strict.length bs < 258 then+ Left "invalid map format 0"+ else+ do lang <- index16 bs 0+ let gmap = M.fromAscList $+ filter ((/= 0).snd) $+ (flip map) [0..255] $ \c ->+ (fromIntegral c, fromIntegral $ Strict.index bs (c+2))+ Right $ CMap UnicodePlatform 0 lang MapFormat0 IS.empty gmap++putMap2 :: CMap -> PutM ()+putMap2 cmap = do+ putWord16be 2+ putWord16be size+ putWord16be (cmapLanguage cmap)+ putCodes 0 255 $ zip (map (fromIntegral.highByte) subTableCodes) [1::Word16 ..]+ for_ subTables $ \(SubTable2 _ fc ec ro _) ->+ do putWord16be fc+ putWord16be ec+ putWord16be 0+ putWord16be ro+ for_ subTables rangeBytes+ where+ highBytes :: [Int]+ highBytes =+ IS.toList $ fst $+ IS.split 255 (multiByte cmap)+ subTableCodes =+ filter ((/= 0) . entryCount) $ + flip map highBytes $ \hb ->+ let subMap = subIntMap (fromIntegral hb `shift` 8)+ (fromIntegral hb `shift` 8 .|. 0xff) $+ glyphMap cmap+ (fstCode, lstCode)+ | M.null subMap = (0, -1)+ | otherwise = (fst $ M.findMin subMap,+ fst $ M.findMax subMap)+ ec = lstCode - fstCode + 1+ rb = subCodes subMap fstCode lstCode+ in SubTable2 (fromIntegral hb) (fromIntegral fstCode) (fromIntegral ec) 0 rb+ where+ subTables = scanl calcOffset firstTable subTableCodes+ firstTable =+ SubTable2 0 0 256 (fromIntegral $ length subTableCodes * 8 + 2) $+ subCodes (glyphMap cmap) 0 255+ size :: Word16+ size = 518 + 8 * (fromIntegral $ length subTables) + 2 * sum (map entryCount subTables)+ calcOffset prev st = st { rangeOffset = rangeOffset prev - 8 + 2*entryCount prev }+ +getMap2 :: Strict.ByteString -> Either String CMap+getMap2 bs = do+ lang <- index16 bs 0+ highBytes <- do+ l <- traverse (index16 bs) [1..256]+ Right $ map fst $ filter ((/=0).snd) $ zip [0::Int ..255] l+ l <- for [0::Word16 .. fromIntegral $ length highBytes] $ \i -> do+ fstCode <- index16 bs (fromIntegral $ 257 + i*4)+ cnt <- index16 bs (fromIntegral $ 257 + i*4 + 1)+ delta <- index16 bs (fromIntegral $ 257 + i*4 + 2)+ ro <- index16 bs (fromIntegral $ 257 + i*4 + 3)+ for [0 .. fromIntegral cnt-1] $ \entry -> do+ p <- index16 bs (fromIntegral $ 257 + i*4 + 3 + ro `quot` 2 + entry)+ Right (fromIntegral $ fstCode + entry, if p == 0 then 0 else p + delta)+ let im = M.fromAscList $ filter ((/= 0).snd) $ concat l+ is = IS.fromAscList $ map fromIntegral highBytes+ Right $ CMap UnicodePlatform 0 lang MapFormat2 is im + +data Segment4 = RangeSegment Word16 Word16 Word16+ | CodeSegment Word16 Word16 [Word16]+ deriving Show++findRange :: Word32 -> Int64 -> [(Word32, Word16)] -> (Word32, [(Word32, Word16)])+findRange nextI _ [] =+ (nextI-1, [])+findRange nextI offset l@((i,c):r)+ | i == nextI && c == fromIntegral (fromIntegral nextI+offset) =+ findRange (nextI+1) offset r+ | otherwise = (nextI-1, l)++findCodes :: Word32 -> [(Word32, Word16)] -> ([GlyphID], [(Word32, Word16)])+findCodes _ [] = ([], [])+findCodes prevI l@((i,c):r)+ -- maximum gap is 4+ | i - prevI > 4 = ([], l)+ | otherwise = (replicate (fromIntegral $ i-prevI-1) 0 ++ c:c2, r2)+ where (c2, r2) = findCodes i r++getSegments :: [(Word32, Word16)] -> [Segment4]+getSegments [] = [RangeSegment 0xffff 1 0]+getSegments l@((start, c):_)+ | fromIntegral end - start >= 4 ||+ lc <= end-start+1 = + RangeSegment (fromIntegral start) (fromIntegral end-fromIntegral start+1) c :+ getSegments r+ | otherwise =+ CodeSegment (fromIntegral start) (fromIntegral lc) codes :+ getSegments r2+ where+ lc = fromIntegral $ length codes+ (end, r) = findRange start (fromIntegral c - fromIntegral start) l+ (codes, r2) = findCodes (start-1) l++data Segment4layout = Segment4layout {+ s4endCode :: Word16,+ s4startCode :: Word16,+ s4idDelta :: Word16,+ s4idRangeOffset :: Word16,+ s4glyphIndex :: [GlyphID] }+ deriving Show+ +putMap4 :: CMap -> PutM ()+putMap4 cmap = do+ putWord16be 4+ putWord16be size+ putWord16be (cmapLanguage cmap)+ putWord16be (segCount*2)+ putWord16be searchRange+ putWord16be entrySelector+ putWord16be $ 2*segCount - searchRange+ traverse_ (put.s4endCode) layout+ putWord16be 0+ traverse_ (put.s4startCode) layout+ traverse_ (put.s4idDelta) layout+ traverse_ (put.s4idRangeOffset) layout+ traverse_ (traverse_ put.s4glyphIndex) layout+ where+ size, segCount, searchRange, entrySelector :: Word16+ entrySelector = iLog2 segCount+ searchRange = 1 `shift` (fromIntegral $ entrySelector+1)+ segments = getSegments $ M.toList $ glyphMap cmap+ (codeSize, layout) = mapAccumL foldLayout (segCount*2) segments+ foldLayout offset (RangeSegment start len code) =+ (offset-2, Segment4layout (fromIntegral $ start+len-1)+ (fromIntegral start) (code-(fromIntegral start)) 0 [])+ foldLayout offset (CodeSegment start len codes) =+ (offset+fromIntegral len*2-2,+ Segment4layout (fromIntegral $ start+len-1)+ (fromIntegral start) 0 offset codes)+ size = 8*segCount + codeSize + 16+ segCount = fromIntegral $ length segments++getMap4 :: Strict.ByteString -> Either String CMap+getMap4 bs = do+ lang <- index16 bs 0+ segCount <- (`quot` 2) <$> index16 bs 1+ gmap <- fmap (M.fromAscList . filter ((/= 0).snd) . concat ) $+ for [0::Word16 .. segCount-2] $ \i ->+ do idDelta <- index16 bs (i + 6 + segCount*2)+ endCode <- index16 bs (i + 5)+ startCode <- index16 bs (i + 6 + segCount)+ idRangeOffset <- index16 bs (i + 6 + segCount*3)+ if idRangeOffset == 0+ then Right [(fromIntegral c, c+idDelta) | c <- [startCode .. endCode]]+ else for [0..endCode-startCode] $ \j ->+ do glyph <- index16 bs (fromIntegral $ i + 6 + segCount*3 + idRangeOffset`div`2 + j)+ Right (fromIntegral $ startCode + j, glyph)+ Right $ CMap UnicodePlatform 0 lang MapFormat4 IS.empty gmap++putMap6 :: CMap -> PutM ()+putMap6 cmap = do+ putWord16be 6+ putWord16be size+ putWord16be (cmapLanguage cmap)+ putWord16be fCode+ putWord16be eCount+ subCodes (glyphMap cmap) (fromIntegral fCode) (fromIntegral lastCode)+ where+ size, eCount, fCode, lastCode :: Word16+ size = eCount*2 + 10+ eCount = lastCode - fCode + 1+ fCode = fromIntegral $+ min (fromIntegral (maxBound :: Word16)::Word32) $+ fst $ M.findMin (glyphMap cmap)+ lastCode = fromIntegral $+ min (fromIntegral (maxBound :: Word16)::Word32) $+ fst $ M.findMax (glyphMap cmap)+ +getMap6 :: Strict.ByteString -> Either String CMap+getMap6 bs = do+ lang <- index16 bs 0+ fCode <- index16 bs 1+ eCount <- index16 bs 2+ gmap <- fmap (M.fromAscList . filter ((/= 0).snd)) $+ for [0..eCount-1] $ \i -> do+ g <- index16 bs (i+3)+ Right (fromIntegral $ i + fCode, g)+ Right $ CMap UnicodePlatform 0 lang MapFormat6 IS.empty gmap++putPacked :: Int -> [Int] -> Put+putPacked start highBytes+ | start >= 8192 = return ()+ | otherwise = do+ putWord8 $ foldl' (.|.) 0 $ map ((shift 1) . (.&. 7)) bytes+ putPacked (start+1) rest+ where+ (bytes, rest) = span (\b -> b >= (start*8) &&+ b < (start+1)*8)+ highBytes++readPacked :: Strict.ByteString -> [Int]+readPacked bs =+ [i .|. b `shift` 3 |+ (a, b) <- zip (Strict.unpack bs) [0..8191],+ i <- [0..7],+ a .&. (1 `shift` i) /= 0+ ]+ ++findRanges :: [(Word32, GlyphID)] -> [(Word32, Word32, GlyphID)]+findRanges [] = []+findRanges l@((i,c):_) = (i, i2, c) : findRanges next+ where (i2, next) = findRange i (fromIntegral c-fromIntegral i) l+ +putMap8 :: CMap -> PutM ()+putMap8 cmap = do+ putWord16be 8+ putWord16be 0+ putWord32be $ fromIntegral size+ putWord32be (fromIntegral $ cmapLanguage cmap)+ putPacked 0 highBytes+ putWord32be $ fromIntegral nGroups+ for_ ranges $ \(start, end, code) -> do+ putWord32be $ fromIntegral start+ putWord32be $ fromIntegral end+ putWord32be $ fromIntegral code+ where+ size = nGroups * 12 + 8208+ highBytes = IS.toList $ multiByte cmap+ ranges = findRanges $ M.toList $ glyphMap cmap+ nGroups = length ranges++getMap8 :: Strict.ByteString -> Either String CMap+getMap8 bs = do+ _ <- index16 bs 0+ lang <- index16 bs 1+ let is = IS.fromAscList $ readPacked (Strict.drop 4 bs)+ nGroups <- index32 bs 2049+ gmap <- fmap (M.fromAscList . concat) $ for [0..nGroups-1] $ \i -> do+ start <- index32 bs (i*3 + 2050)+ end <- index32 bs (i*3 + 2051)+ glyph <- index32 bs (i*3 + 2052)+ return [(fromIntegral c, fromIntegral $ glyph+c-start) | c <- [start .. end]]+ Right $ CMap UnicodePlatform 0 lang MapFormat8 is gmap++getMap10 :: Strict.ByteString -> Either String CMap+getMap10 bs = do+ lang <- index32 bs 0+ fCode <- index32 bs 1+ eCount <- index32 bs 2+ gmap <- fmap (M.fromAscList . filter ((/= 0).snd)) $+ for [0..eCount-1] $ \i -> do+ g <- index16 bs (fromIntegral i+6)+ Right (fromIntegral $ i + fCode, g)+ Right $ CMap UnicodePlatform 0 (fromIntegral lang) MapFormat6 IS.empty gmap+++putMap10 :: CMap -> Put+putMap10 cmap = do+ putWord16be 10+ putWord16be 0+ putWord32be size+ putWord32be $ fromIntegral $ cmapLanguage cmap+ putWord32be fCode+ putWord32be eCount+ subCodes (glyphMap cmap) (fromIntegral fCode) (fromIntegral lastCode)+ where+ size, eCount, fCode, lastCode :: Word32+ size = eCount*2 + 20+ eCount = lastCode - fCode + 1+ fCode = fromIntegral $ fst $ M.findMin $ glyphMap cmap+ lastCode = fromIntegral $ fst $ M.findMax $ glyphMap cmap++putMap12 :: CMap -> PutM ()+putMap12 cmap = do+ putWord16be 12+ putWord16be 0+ putWord32be $ fromIntegral size+ putWord32be (fromIntegral $ cmapLanguage cmap)+ putWord32be $ fromIntegral nGroups+ for_ ranges $ \(start, end, code) -> do+ putWord32be $ fromIntegral start+ putWord32be $ fromIntegral end+ putWord32be $ fromIntegral code+ where+ size = nGroups * 12 + 16+ ranges = findRanges $ M.toList $ glyphMap cmap+ nGroups = length ranges++getMap12 :: Strict.ByteString -> Either String CMap+getMap12 bs = do+ _ <- index16 bs 0+ lang <- index16 bs 1+ nGroups <- index32 bs 1+ gmap <- fmap (M.fromAscList . concat) $ for [0..nGroups-1] $ \i -> do+ start <- index32 bs (i*3 + 2)+ end <- index32 bs (i*3 + 3)+ glyph <- index32 bs (i*3 + 4)+ return [(fromIntegral c, fromIntegral $ glyph+c-start) | c <- [start .. end]]+ Right $ CMap UnicodePlatform 0 lang MapFormat8 IS.empty gmap+
+ Opentype/Fileformat/Glyph.hs view
@@ -0,0 +1,534 @@+{-# LANGUAGE MultiWayIf, TupleSections #-}+module Opentype.Fileformat.Glyph where+import Opentype.Fileformat.Types+import Opentype.Fileformat.Maxp+import Opentype.Fileformat.Hhea+import Opentype.Fileformat.Head+import qualified Data.Vector as V+import Data.Foldable (traverse_, for_)+import Control.Monad+import Data.Function (fix)+import qualified Data.ByteString.Lazy as Lazy+import qualified Data.ByteString as Strict+import Data.Word+import Data.Int+import Data.Maybe (isJust)+import Data.Bits+import Data.Binary+import Data.Binary.Put+import Data.Binary.Get+++-- | This table contains the data that defines the appearance of+-- the glyphs in the font. This includes specification of the points+-- that describe the contours that make up a glyph outline and the+-- instructions that grid-fit that glyph. The glyf table supports the+-- definition of simple glyphs and compound glyphs, that is, glyphs+-- that are made up of other glyphs.+data GlyfTable = GlyfTable (V.Vector Glyph)+ deriving Show++data Glyph = Glyph {+ advanceWidth :: Word16,+ leftSideBearing :: Int16,+ glyphXmin :: FWord,+ glyphYmin :: FWord,+ glyphXmax :: FWord,+ glyphYmax :: FWord,+ glyphOutlines :: GlyphOutlines}+ deriving Show++data GlyphOutlines =+ GlyphContours [[CurvePoint]] Instructions |+ CompositeGlyph [GlyphComponent]+ deriving Show++-- | @CurvePoint x y onCurve@: Points used to describe the outline+-- using lines and quadratic beziers. Coordinates are absolute (not+-- relative). If two off-curve points follow each other, an on-curve+-- point is added halfway between.+data CurvePoint = CurvePoint FWord FWord Bool+ deriving Show++-- | TODO: make a proper datatype for instructions.+type Instructions = V.Vector Word8++data GlyphComponent =+ GlyphComponent {+ componentID :: Int,+ componentInstructions :: Maybe Instructions,+ -- | transformation matrix for scaling the glyph+ componentXX :: ShortFrac,+ -- | transformation matrix for scaling the glyph+ componentXY :: ShortFrac,+ -- | transformation matrix for scaling the glyph+ componentYX :: ShortFrac,+ -- | transformation matrix for scaling the glyph+ componentYY :: ShortFrac,+ -- | if `matchPoints` is `True`, index of matching point in compound+ -- being constructed, otherwise x shift. If `scaledComponentOffset`+ -- is `False`, this offset is unscaled (microsoft and opentype+ -- default) in the rasterizer.+ componentX :: Int,+ -- | if `matchPoints` is `True`, index of matching point in compound,+ -- otherwise y shift. If `scaledComponentOffset` is `False`, this+ -- offset is unscaled (microsoft and opentype default) in the+ -- rasterizer.+ componentY :: Int,+ -- | see previous+ matchPoints :: Bool,+ -- | For the xy values if `matchPoints` is `False`.+ roundXYtoGrid :: Bool,+ -- | Use metrics from this component for the compound glyph.+ useMyMetrics :: Bool, + -- | If set, the components of the compound glyph overlap. Use of+ -- this flag is not required in OpenType — that is, it is valid to+ -- have components overlap without having this flag set. It may+ -- affect behaviors in some platforms, however. (See Apple’s+ -- specification for details regarding behavior in Apple platforms.)+ overlapCompound :: Bool,+ -- | The component offset is scaled by the rasterizer (apple). Should be+ -- set to `False` (opentype default), unless the font is meant to work+ -- with old apple software.+ scaledComponentOffset :: Bool+ }+ deriving Show++emptyGlyph :: Glyph+emptyGlyph = Glyph 0 0 0 0 0 0 (GlyphContours [] V.empty)++readHmetrics :: Int -> Int -> Get [(Word16, Int16)]+readHmetrics 1 m = do+ aw <- getWord16be+ lsb <- getInt16be+ ((aw, lsb):) <$> replicateM (m-1) ((aw,) <$> getInt16be)++readHmetrics 0 _ = fail "no horizontal metrics found"+readHmetrics n m = do+ aw <- getWord16be+ lsb <- getInt16be+ ((aw, lsb):) <$> readHmetrics (n-1) (m-1)++readGlyphLocs :: Bool -> Int -> Get [Int]+readGlyphLocs long n =+ replicateM (n+1) $ + if long then fromIntegral <$> getWord32be+ else (*2).fromIntegral <$> getWord16be+ +readGlyphTable :: [(Int, Int)] -> [(Word16, Int16)] -> Strict.ByteString+ -> Either String (V.Vector Glyph)+readGlyphTable glyphSizes hmetrics glyfBs =+ V.fromList <$> zipWithM readGlyph glyphSizes hmetrics+ where+ readGlyph (offset, size) (aw, lsb)+ | offset + size > Strict.length glyfBs =+ Left "glyph past table bounds."+ | otherwise =+ case runGetOrFail getGlyph (Lazy.fromStrict $ Strict.drop offset glyfBs) of+ Left (_, _, err) -> Left err+ Right (_, _, g) -> Right $ g {advanceWidth = aw, leftSideBearing = lsb}++-- return bytestring lengths+writeGlyphs :: V.Vector Glyph -> PutM (V.Vector Int)+writeGlyphs = traverse writeGlyph++writeGlyph :: Glyph -> PutM Int+writeGlyph g = do+ putLazyByteString bs+ replicateM_ pad (putWord8 0)+ return $ fromIntegral (len+pad)+ where bs = runPut $ putGlyph g+ len = fromIntegral $ Lazy.length bs+ pad = (- fromIntegral len) .&. 3+ +-- return long or short format +writeLoca :: V.Vector Int -> PutM Bool+writeLoca vec+ | V.last offsets > 0xffff =+ do traverse_ (putWord32be . fromIntegral) offsets+ return True+ | otherwise =+ do traverse_ (putWord16be . (`quot` 2) . fromIntegral) offsets+ return False+ where+ offsets = V.scanl (+) 0 vec+ +writeHmtx :: V.Vector Glyph -> PutM Int+writeHmtx gs+ | V.null gs = return 0+ | otherwise = + do traverse_ (\g -> do putWord16be (advanceWidth g)+ putInt16be (leftSideBearing g)+ ) dbl+ traverse_ (putInt16be.leftSideBearing) sngl+ return (len-tl)+ where+ findTail i cnt+ | i < 0 = cnt+ | advanceWidth (V.unsafeIndex gs i) == aw =+ findTail (i-1) (cnt+1)+ | otherwise = cnt+ aw = advanceWidth (V.unsafeLast gs)+ len = V.length gs+ tl = findTail (len-2) 0+ (dbl, sngl) = V.splitAt (len-tl) gs+ +putGlyph :: Glyph -> Put+putGlyph (Glyph _ _ xmin ymin xmax ymax outlines) = do+ putInt16be $ case outlines of+ GlyphContours pts _ -> fromIntegral $ length pts+ _ -> -1+ putInt16be xmin+ putInt16be ymin+ putInt16be xmax+ putInt16be ymax+ case outlines of+ GlyphContours pts instrs ->+ putContour pts instrs+ CompositeGlyph comps -> do+ traverse_ (putComponent True) (init comps)+ putComponent False $ last comps++getGlyph :: Get Glyph+getGlyph = do+ n <- getInt16be+ xmin <- getInt16be+ ymin <- getInt16be+ xmax <- getInt16be+ ymax <- getInt16be+ outlines <-+ if n >= 0+ then getContour (fromIntegral n)+ else fmap CompositeGlyph $ fix $ \nextComponent -> do+ (c, more) <- getComponent+ if more then (c:) <$> nextComponent+ else return [c]+ return $ Glyph 0 0 xmin ymin xmax ymax outlines++isShort :: FWord -> Bool+isShort n = abs n <= 255++putCompressFlags :: [Word8] -> Put+putCompressFlags [] = return ()+putCompressFlags (a:r) =+ do if null as+ then putWord8 a+ else do putWord8 (a .|. 8)+ putWord8 $ fromIntegral $ length as+ putCompressFlags r2+ where+ (as, r2) = span (== a) r+ +contourFlag :: CurvePoint -> Word8 +contourFlag (CurvePoint x y oc) =+ fromIntegral $ + makeFlag [oc, sx && x /= 0, sy && y /= 0, False,+ x == 0 || (sx && x >= 0),+ y == 0 || (sy && y >= 0)]+ where+ sx = isShort x+ sy = isShort y++firstFlag :: CurvePoint -> Word8+firstFlag (CurvePoint x y oc) =+ fromIntegral $+ makeFlag [oc, sx, sy, False, sx && x >= 0, sy && y >= 0]+ where sx = isShort x+ sy = isShort y+ +putCoordX :: CurvePoint -> Word8 -> Put+putCoordX (CurvePoint x _ _) flag+ | byteAt flag 1 = putWord8 (fromIntegral $ abs x)+ | byteAt flag 4 = return ()+ | otherwise = putInt16be (fromIntegral x)+ +putCoordY :: CurvePoint -> Word8 -> Put+putCoordY (CurvePoint _ y _) flag+ | byteAt flag 2 = putWord8 (fromIntegral $ abs y)+ | byteAt flag 5 = return ()+ | otherwise = putInt16be (fromIntegral y)++putContour :: [[CurvePoint]] -> V.Vector Word8 -> Put +putContour points instr = do+ traverse_ (putWord16be.fromIntegral) endPts+ putWord16be $ fromIntegral $ V.length instr+ traverse_ putWord8 instr+ putCompressFlags flags+ zipWithM_ putCoordX allPts flags+ zipWithM_ putCoordY allPts flags+ where+ endPts = tail $ scanl (+) (-1) $ map length points+ allPts = case concat points of+ [] -> []+ pts@(p: pts2) -> p: zipWith subCoord pts2 pts+ subCoord (CurvePoint x1 y1 _) (CurvePoint x2 y2 on) =+ CurvePoint (x2-x1) (y2-y1) on+ flags = case allPts of+ [] -> []+ (p:pts) -> firstFlag p : map contourFlag pts++getFlags :: Int -> Get [Word8]+getFlags n+ | n <= 0 = return []+ | otherwise = do+ flag <- getWord8+ if flag .&. 8 /= 0 && n > 1+ then do m <- fromIntegral <$> getWord8+ (replicate (min (m+1) n) flag ++) <$> getFlags (n-m-1)+ else (flag:) <$> getFlags (n-1)++getXcoords, getYcoords :: [Word8] -> Get [FWord]+getXcoords [] = return []+getXcoords (f:r) + | byteAt f 1 = do+ x <- getWord8+ let x' | byteAt f 4 = fromIntegral x+ | otherwise = - fromIntegral x+ (x':) <$> getXcoords r+ | byteAt f 4 = (0:) <$> getXcoords r+ | otherwise = do+ x <- fromIntegral <$> getInt16be+ (x:) <$> getXcoords r++getYcoords [] = return []+getYcoords (f:r) + | byteAt f 2 = do+ y <- getWord8+ let y' | byteAt f 5 = fromIntegral y+ | otherwise = - fromIntegral y+ (y':) <$> getYcoords r+ | byteAt f 5 = (0:) <$> getYcoords r+ | otherwise = do+ y <- fromIntegral <$> getInt16be+ (y:) <$> getYcoords r++getPoint :: FWord -> FWord -> Word8 -> CurvePoint+getPoint x y flag = CurvePoint x y (byteAt flag 0)++reGroup :: [a] -> [Int] -> [[a]]+reGroup _ [] = []+reGroup l (n:ns) = c : reGroup r ns+ where+ (c, r) = splitAt n l++toOffsets :: (Num a) => [a] -> [a]+toOffsets [] = []+toOffsets (x:xs) = scanl (-) x xs+ +getContour :: Int -> Get GlyphOutlines+getContour 0 = return $ GlyphContours [] V.empty+getContour nContours = do+ lastPts <- replicateM nContours (fromIntegral <$> getWord16be)+ iLen <- fromIntegral <$> getWord16be+ instructions <- V.replicateM iLen getWord8+ flags <- getFlags $ last lastPts + 1+ xCoords <- toOffsets <$> getXcoords flags+ yCoords <- toOffsets <$> getYcoords flags+ let coords = zipWith3 getPoint xCoords yCoords flags+ contours = reGroup coords $+ zipWith (-) lastPts ((-1):lastPts)+ return $ GlyphContours contours instructions++isShortInt :: Int -> Bool+isShortInt x = x <= 127 && x >= -128++glyphExtent, glyphRsb :: Glyph -> Int16+glyphRsb g =+ fromIntegral (advanceWidth g) - glyphExtent g+ +glyphExtent glyf = leftSideBearing glyf + (glyphXmax glyf - glyphXmin glyf)++updateHhea :: V.Vector Glyph -> HheaTable -> HheaTable+updateHhea v h = V.foldl updateHhea1+ (h {advanceWidthMax = minBound,+ minLeftSideBearing = maxBound,+ minRightSideBearing = maxBound,+ xMaxExtent = minBound})+ v+ ++updateMinMax :: (FWord, FWord, FWord, FWord)+ -> Glyph -> (FWord, FWord, FWord, FWord)+updateMinMax (xmin, ymin, xmax, ymax) g =+ (min xmin (glyphXmin g),+ min ymin (glyphYmin g),+ max xmax (glyphXmax g),+ max ymax (glyphYmax g))++updateHead :: V.Vector Glyph -> HeadTable -> HeadTable+updateHead vec headTbl =+ headTbl {xMin = xmin, yMin = ymin,+ xMax = xmax, yMax = ymax}+ where (xmin, ymin, xmax, ymax) =+ V.foldl updateMinMax (maxBound, maxBound, minBound, minBound) vec++updateHhea1 :: HheaTable -> Glyph -> HheaTable+updateHhea1 hhea g =+ hhea {advanceWidthMax = max (advanceWidthMax hhea)+ (advanceWidth g),+ minLeftSideBearing = min (minLeftSideBearing hhea)+ (leftSideBearing g),+ minRightSideBearing = min (minRightSideBearing hhea)+ (glyphRsb g),+ xMaxExtent = max (xMaxExtent hhea)+ (glyphExtent g)}+updateMaxp :: V.Vector Glyph -> MaxpTable -> MaxpTable+updateMaxp vec tbl = V.foldl (updateMaxp1 vec)+ (tbl {numGlyphs = 0,+ maxPoints = 0,+ maxContours = 0,+ maxComponentPoints = 0,+ maxComponentContours = 0,+ maxComponentElements = 0,+ maxComponentDepth = 0})+ vec++updateMaxp1 :: V.Vector Glyph -> MaxpTable -> Glyph -> MaxpTable+updateMaxp1 vec maxp glyf =+ maxp {numGlyphs = numGlyphs maxp + 1,+ maxPoints = max (maxPoints maxp) $+ glyfPoints vec glyf,+ maxContours = max (maxContours maxp) $+ glyfContours vec glyf,+ maxComponentPoints = max (maxComponentPoints maxp) $+ componentPoints vec glyf,+ maxComponentContours = max (maxComponentContours maxp) $+ componentContours vec glyf,+ maxComponentElements = max (maxComponentElements maxp) $+ componentRefs vec glyf,+ maxComponentDepth = max (maxComponentDepth maxp) $+ componentDepth vec glyf}++overComponents :: ([[CurvePoint]] -> Word16) -> ([Word16] -> Word16)+ -> Int -> Bool -> V.Vector Glyph -> Glyph -> Word16+overComponents f h maxD d v g+ | maxD <= 0 = 0+ | otherwise =+ case glyphOutlines g of+ GlyphContours p _+ | d -> 0+ | otherwise -> f p+ CompositeGlyph comps ->+ h $ map overSub comps+ where overSub comp = case v V.!? componentID comp of+ Nothing -> 0+ Just g2 -> overComponents f h (maxD-1) False v g2 + +glyfPoints, glyfContours, componentRefs, componentDepth, componentPoints, componentContours :: V.Vector Glyph -> Glyph -> Word16++glyfPoints =+ overComponents (sum . map (fromIntegral.length)) (const 0) 2 False++glyfContours =+ overComponents (fromIntegral.length) (const 0) 2 False++componentRefs =+ overComponents (const 0) (fromIntegral.length) 2 True++componentPoints =+ overComponents (sum . map (fromIntegral . length)) sum 10 True++componentDepth =+ overComponents (const 0) ((+1).maximum) 10 True++componentContours =+ overComponents (fromIntegral.length) sum 10 True++putComponent :: Bool -> GlyphComponent -> Put+putComponent more c = do+ putWord16be flag+ putWord16be $ fromIntegral $ componentID c+ case (byteAt flag 0, byteAt flag 1) of+ (False, False) -> do+ putWord8 $ fromIntegral $ componentX c+ putWord8 $ fromIntegral $ componentY c+ (False, True) -> do+ putInt8 $ fromIntegral $ componentX c+ putInt8 $ fromIntegral $ componentY c+ (True, False) -> do+ putWord16be $ fromIntegral $ componentX c+ putWord16be $ fromIntegral $ componentY c+ (True, True) -> do+ putInt16be $ fromIntegral $ componentX c+ putInt16be $ fromIntegral $ componentY c+ when (flag .&. (shift 1 3 + shift 1 6 + shift 1 7) /= 0) $+ putShortFrac $ componentXX c+ when (byteAt flag 7) $ do+ putShortFrac $ componentXY c+ putShortFrac $ componentYX c+ when (flag .&. (shift 1 6 + shift 1 7) /= 0) $+ putShortFrac $ componentYY c+ for_ (componentInstructions c) $ \instr -> do+ putWord16be $ fromIntegral $ V.length instr+ traverse_ putWord8 instr+ where+ flag = makeFlag [+ if matchPoints c+ then componentX c > 0xff ||+ componentY c > 0xff+ else (not $ isShortInt $ componentX c) ||+ (not $ isShortInt $ componentY c),+ not $ matchPoints c,+ roundXYtoGrid c,+ componentXX c /= 1 &&+ componentXX c == componentYY c &&+ componentXY c == 0 && componentYX c == 0,+ False,+ more,+ componentXX c /= componentYY c &&+ componentXY c == 0 && componentYX c == 0,+ componentXY c /= 0 || componentYX c /= 0,+ isJust (componentInstructions c),+ useMyMetrics c,+ overlapCompound c,+ scaledComponentOffset c,+ not $ scaledComponentOffset c]++getComponent :: Get (GlyphComponent, Bool)+getComponent = do+ flag <- getWord16be+ gID <- getWord16be+ (cX, cY) <-+ if | byteAt flag 0 && byteAt flag 1 ->+ liftM2 (,)+ (fromIntegral <$> getInt16be)+ (fromIntegral <$> getInt16be)+ | byteAt flag 0 ->+ liftM2 (,)+ (fromIntegral <$> getWord16be)+ (fromIntegral <$> getWord16be)+ | byteAt flag 1 ->+ liftM2 (,)+ (fromIntegral <$> getInt8)+ (fromIntegral <$> getInt8)+ | otherwise ->+ liftM2 (,)+ (fromIntegral <$> getWord8)+ (fromIntegral <$> getWord8)+ (tXX, tXY, tYX, tYY) <-+ if | byteAt flag 3 -> do+ x <- ShortFrac <$> getInt16be+ return (x, 0, 0, x)+ | byteAt flag 6 -> do+ x <- ShortFrac <$> getInt16be+ y <- ShortFrac <$> getInt16be+ return (x, 0, 0, y)+ | byteAt flag 7 -> do+ xx <- ShortFrac <$> getInt16be+ xy <- ShortFrac <$> getInt16be+ yx <- ShortFrac <$> getInt16be+ yy <- ShortFrac <$> getInt16be+ return (xx, xy, yx, yy)+ | otherwise -> return (1, 0, 0, 1)+ instructions <- + if byteAt flag 8+ then Just <$> do+ l <- fromIntegral <$> getWord16be+ V.replicateM l getWord8+ else return Nothing+ return (+ GlyphComponent (fromIntegral gID) instructions tXX tXY tYX tYY+ cX cY (not $ byteAt flag 1) (byteAt flag 2)+ (byteAt flag 9) (byteAt flag 10) (byteAt flag 11),+ byteAt flag 5) -- more components+
+ Opentype/Fileformat/Head.hs view
@@ -0,0 +1,186 @@+module Opentype.Fileformat.Head where+import Opentype.Fileformat.Types+import Data.Time+import Data.Binary+import Data.Binary.Get+import Data.Binary.Put+import Control.Monad+import Data.Int++-- | This table contains global information about the font. it+-- records such facts as the font version number, the creation and+-- modification dates, revision number and basic typographic data that+-- applies to the font as a whole. this includes a specification of+-- the font bounding box, the direction in which the font's glyphs are+-- most likely to be written and other information about the placement+-- of glyphs in the em square.+data HeadTable = HeadTable {+ -- | 0x00010000 for version 1.0. /Will be auto written./+ headVersion :: Fixed,+ -- | set by font manufacturer.+ fontRevision :: Fixed,+ -- | baseline for font at y=0+ baselineYZero :: Bool,+ -- | left sidebearing point at x=0;+ sidebearingXZero :: Bool,+ -- | instructions may depend on point size;+ pointsizeDepend :: Bool,+ -- | Force ppem to integer values for all internal scaler math; may+ -- use fractional ppem sizes if this bit is clear;+ integerScaling :: Bool, + -- | /Microsoft/: Instructions may alter advance width (the advance widths might not scale linearly);+ alterAdvanceWidth :: Bool,+ -- | /Apple/: This bit should be set in fonts that are intended to e+ -- laid out vertically, and in which the glyphs have been drawn such+ -- that an x-coordinate of 0 corresponds to the desired vertical+ -- baseline.+ + -- bit 6 zero+ verticalFont :: Bool,+ -- | /Apple/: This should be set if the font requires layout for+ -- correct linguistic rendering (e.g. Arabic fonts).+ linguisticRenderingLayout :: Bool,+ -- | /Apple/: This should be set for an AAT font which has one or more+ -- metamorphosis effects designated as happening by default.+ metamorphosisEffects :: Bool,+ -- | his bit should be set if the font contains any strong+ -- right-to-left glyphs.+ rightToLeftGlyphs :: Bool,+ -- | This bit should be set if the font contains Indic-style+ -- rearrangement effects.+ indicRearrangements :: Bool,+ -- | /Adobe/: Font data is ‘lossless’ as a results of having been+ -- subjected to optimizing transformation and/or compression (such+ -- as e.g. compression mechanisms defined by ISO/IEC 14496-18,+ -- MicroType Express, WOFF 2.0 or similar) where the original font+ -- functionality and features are retained but the binary+ -- compatibility between input and output font files is not+ -- guaranteed. As a result of the applied transform, the ‘DSIG’+ -- Table may also be invalidated.+ losslessFontData :: Bool,+ -- | /Adobe/: Font converted (produce compatible metrics)+ convertedFont :: Bool,+ -- | /Adobe/: Font optimized for ClearType™. Note, fonts that rely on+ -- embedded bitmaps (EBDT) for rendering should not be considered+ -- optimized for ClearType, and therefore should keep this bit+ -- cleared.+ clearTypeOptimized :: Bool,+ -- | Last Resort font. If set, indicates that the glyphs encoded in+ -- the cmap subtables are simply generic symbolic representations of+ -- code point ranges and don’t truly represent support for those+ -- code points. If unset, indicates that the glyphs encoded in the+ -- cmap subtables represent proper support for those code points.+ lastResortFont :: Bool,+ -- | Valid range is from 16 to 16384. This value should be a power+ -- of 2 for fonts that have TrueType outlines.++ -- bit 15 zero+ unitsPerEm :: Word16,+ created :: UTCTime, modified :: UTCTime,+ -- | /Will be auto written./+ xMin :: FWord,+ -- | /Will be auto written./+ yMin :: FWord,+ -- | /Will be auto written./+ xMax :: FWord,+ -- | /Will be auto written./+ yMax :: FWord,+ -- macStyle+ + boldStyle :: Bool,+ italicStyle :: Bool,+ underlineStyle :: Bool,+ outlineStyle :: Bool,+ shadowStyle :: Bool,+ condensedStyle :: Bool,+ extendedStyle :: Bool,+ -- | Smallest readable size in pixels.+ lowerRecPPEM :: Word16,+ -- | deprecated, will be set to 2+ fontDirectionHint :: Int16,+ -- | 0 for short offsets, 1 for long. /Will be auto written./+ longLocIndices :: Bool,+ -- | 0 for current format. /Will be auto written./+ glyphDataFormat :: Int16+ }+ deriving Show++getHeadTable :: Get HeadTable+getHeadTable = do+ major <- getWord16be+ minor <- getWord16be+ when (major /= 1 && minor /= 0)+ (fail "Invalid head table")+ revision <- getWord32be+ _ <- getWord32be+ magic <- getWord32be+ when (magic /= 0x5F0F3CF5)+ (fail "Invalid magic value in head table")+ flags <- getWord16be+ uPe <- getWord16be+ created_ <- getInt64be+ modified_ <- getInt64be+ xMin_ <- getInt16be+ yMin_ <- getInt16be+ xMax_ <- getInt16be+ yMax_ <- getInt16be+ mcStyle <- getWord16be+ lRec <- getWord16be+ fDir <- getInt16be+ iToL <- getInt16be+ gd <- getInt16be+ let flagAt = byteAt flags+ styleAt = byteAt mcStyle+ return $ HeadTable 0x00010000 revision+ (flagAt 0) (flagAt 1) (flagAt 2) (flagAt 3)+ (flagAt 4) (flagAt 5) (flagAt 7) (flagAt 8) (flagAt 9)+ (flagAt 10) (flagAt 11) (flagAt 12) (flagAt 13) (flagAt 14) + uPe (getTime created_) (getTime modified_)+ xMin_ yMin_ xMax_ yMax_+ (styleAt 0) (styleAt 1) (styleAt 2) (styleAt 3) (styleAt 4)+ (styleAt 5) (styleAt 6) lRec fDir (iToL /= 0) gd++putHeadTable :: HeadTable -> Put+putHeadTable headTbl = do+ putWord16be 1+ putWord16be 0+ putWord32be $ fontRevision headTbl+ putWord32be 0+ putWord32be 0x5F0F3CF5+ putWord16be $ makeFlag $ map ($ headTbl)+ [baselineYZero, sidebearingXZero, pointsizeDepend, integerScaling, alterAdvanceWidth,+ const False, verticalFont, linguisticRenderingLayout, metamorphosisEffects, rightToLeftGlyphs,+ indicRearrangements, losslessFontData, convertedFont, clearTypeOptimized, lastResortFont, const False]+ putWord16be $ unitsPerEm headTbl+ putInt64be $ putTime $ created headTbl+ putInt64be $ putTime $ modified headTbl+ putInt16be $ xMin headTbl+ putInt16be $ yMin headTbl+ putInt16be $ xMax headTbl+ putInt16be $ yMax headTbl+ putWord16be $ makeFlag $ map ($ headTbl)+ [boldStyle, italicStyle, underlineStyle, outlineStyle, shadowStyle, condensedStyle, extendedStyle]+ putWord16be $ lowerRecPPEM headTbl+ putInt16be 2 -- fontDirectionHint headTbl+ putInt16be $ fromIntegral $ fromEnum $ longLocIndices headTbl+ putInt16be 0 -- glyphDataFormat headTbl++secDay :: Int64+secDay = 60 * 60 * 24++diffSeconds :: Int64+diffSeconds =+ secDay * fromIntegral (fromGregorian 1858 11 17 `diffDays` fromGregorian 1904 1 1)++getTime :: Int64 -> UTCTime+getTime secs = UTCTime (ModifiedJulianDay $ fromIntegral d) (secondsToDiffTime $ fromIntegral t)+ where (d,t) = (secs - diffSeconds) `quotRem` fromIntegral secDay++putTime :: UTCTime -> Int64+putTime (UTCTime (ModifiedJulianDay d) t) =+ fromIntegral d * secDay + diffTimeToSeconds t + diffSeconds++diffTimeToSeconds :: DiffTime -> Int64+diffTimeToSeconds d =+ fromIntegral $ diffTimeToPicoseconds d `quot` 1000000000+
+ Opentype/Fileformat/Hhea.hs view
@@ -0,0 +1,61 @@+module Opentype.Fileformat.Hhea+where+import Opentype.Fileformat.Types+import Data.Binary.Get+import Data.Binary.Put+import Data.Int+import Data.Word+import Control.Monad++-- | This table contains information for horizontal layout. +data HheaTable = HheaTable {+ -- | 0x00010000 (1.0), will be auto written.+ version :: Fixed,+ -- | Distance from baseline of highest ascender+ ascent :: FWord,+ -- | Distance from baseline of lowest descender+ descent :: FWord,+ -- | typographic line gap+ lineGap :: FWord,+ -- | /Will be auto written./+ advanceWidthMax :: UFWord,+ -- | /Will be auto written./+ minLeftSideBearing :: FWord,+ -- | /Will be auto written./+ minRightSideBearing :: FWord,+ -- | /Will be auto written./+ xMaxExtent :: FWord,+ -- | used to calculate the slope of the caret (rise/run) set to 1 for vertical caret+ caretSlopeRise :: Int16,+ -- | 0 for vertical+ caretSlopeRun :: Int16,+ -- | set value to 0 for non-slanted fonts+ caretOffset :: FWord,+ -- | number of advance widths in metrics table. /Will be auto written./+ numOfLongHorMetrics :: Word16}+ deriving Show++putHheaTable :: HheaTable -> Put+putHheaTable table = do+ putWord32be 0x00010000+ putInt16be $ ascent table+ putInt16be $ descent table+ putInt16be $ lineGap table+ putWord16be $ advanceWidthMax table+ putInt16be $ minLeftSideBearing table+ putInt16be $ minRightSideBearing table+ putInt16be $ xMaxExtent table+ putInt16be $ caretSlopeRise table+ putInt16be $ caretSlopeRun table+ putInt16be $ caretOffset table+ replicateM_ 5 $ putInt16be 0+ putWord16be $ numOfLongHorMetrics table+ +getHheaTable :: Get HheaTable+getHheaTable =+ HheaTable <$> getWord32be <*> getInt16be <*>+ getInt16be <*> getInt16be <*> getWord16be <*>+ getInt16be <*> getInt16be <*> getInt16be <*>+ getInt16be <*> getInt16be <*> getInt16be <*>+ (skip 10 *> getWord16be)+
+ Opentype/Fileformat/Kern.hs view
@@ -0,0 +1,69 @@+module Opentype.Fileformat.Kern+where+import Opentype.Fileformat.Types+import Data.Word+import Data.Binary.Put+import Data.Binary.Get+import Data.Bits+import Control.Monad+import Data.Foldable++-- | @KernPair left right adjustment@: Pair of kerning values. left+-- and right are indices in the glyph table.+data KernPair = KernPair Word16 Word16 FWord+ deriving Show++data KernTable = KernTable {+ -- | various flags+ coverage :: Word8,+ kernPairs :: [KernPair]}+ deriving Show++getKernTable :: Get KernTable+getKernTable = do+ version <- getWord16be+ when (version /= 0) $+ fail "Unsupported kern table."+ nTables <- getWord16be+ if nTables == 0+ then return $ KernTable 0 []+ else do+ skip 4+ cov <- getWord16be+ if cov .&. 0xff00 /= 0+ then return $ KernTable 0 []+ else do+ nPairs <- getWord16be+ skip 6+ fmap (KernTable (fromIntegral $ cov .&. 0xff)) $+ replicateM (fromIntegral nPairs) $+ KernPair <$> getWord16be <*> getWord16be <*> getInt16be++putKernTable :: KernTable -> Put+putKernTable (KernTable cov pairs) = do+ putWord16be 0+ putWord16be 1+ putWord16be 0+ putWord16be $ fromIntegral $ 14+6 * length pairs+ putWord16be $ fromIntegral cov+ putWord16be $ fromIntegral len+ putWord16be searchRange+ putWord16be entrySelector+ putWord16be $ len*6 - searchRange+ for_ pairs $ \(KernPair l r v) -> do+ putWord16be l+ putWord16be r+ putInt16be v+ where+ len = fromIntegral $ length pairs+ entrySelector = fromIntegral $ iLog2 len+ searchRange = 6 * (1 `shift` fromIntegral entrySelector)+ + +++ + + + +
+ Opentype/Fileformat/Maxp.hs view
@@ -0,0 +1,72 @@+module Opentype.Fileformat.Maxp+where+import Opentype.Fileformat.Types+import Data.Binary.Get+import Data.Binary.Put+import Data.Word+++-- | The 'maxp' table establishes the memory requirements for a font.+-- Only instruction data needs to be filled in, since instructions+-- aren't yet supported. __Note:__ The cff version of this table will+-- be handled automatically.+data MaxpTable = MaxpTable {+ -- | 0x00010000 (1.0). /Will be auto written./ + maxpVersion :: Fixed,+ -- | the number of glyphs in the font. /Will be auto written./+ numGlyphs :: Word16,+ -- | points in non-compound glyph. /Will be auto written./+ maxPoints :: Word16,+ -- | contours in non-compound glyph. /Will be auto written./+ maxContours :: Word16,+ -- | points in compound glyph. /Will be auto written./+ maxComponentPoints :: Word16,+ -- | contours in compound glyph. /Will be auto written./+ maxComponentContours :: Word16,+ -- | set to 2+ maxZones :: Word16,+ -- | points used in Twilight Zone (Z0)+ maxTwilightPoints :: Word16,+ -- | number of Storage Area locations+ maxStorage :: Word16,+ -- | number of FDEFs+ maxFunctionDefs :: Word16,+ -- | number of IDEFs+ maxInstructionDefs :: Word16,+ -- | maximum stack depth+ maxStackElements :: Word16,+ -- | byte count for glyph instructions+ maxSizeOfInstructions :: Word16,+ -- | number of glyphs referenced at top level. /Will be auto written./+ maxComponentElements :: Word16,+ -- | levels of recursion. /Will be auto written./+ maxComponentDepth :: Word16}+ deriving Show++putMaxpTable :: MaxpTable -> Put+putMaxpTable maxp = do+ putWord32be $ maxpVersion maxp+ putWord16be $ numGlyphs maxp+ putWord16be $ maxPoints maxp+ putWord16be $ maxContours maxp+ putWord16be $ maxComponentPoints maxp+ putWord16be $ maxComponentContours maxp+ putWord16be $ maxZones maxp+ putWord16be $ maxTwilightPoints maxp+ putWord16be $ maxStorage maxp+ putWord16be $ maxFunctionDefs maxp+ putWord16be $ maxInstructionDefs maxp+ putWord16be $ maxStackElements maxp+ putWord16be $ maxSizeOfInstructions maxp+ putWord16be $ maxComponentElements maxp+ putWord16be $ maxComponentDepth maxp+ +getMaxpTable :: Get MaxpTable+getMaxpTable =+ MaxpTable <$> getWord32be <*>+ getWord16be <*> getWord16be <*> getWord16be <*>+ getWord16be <*> getWord16be <*> getWord16be <*>+ getWord16be <*> getWord16be <*> getWord16be <*>+ getWord16be <*> getWord16be <*> getWord16be <*>+ getWord16be <*> getWord16be +
+ Opentype/Fileformat/Name.hs view
@@ -0,0 +1,95 @@+module Opentype.Fileformat.Name+where+import Opentype.Fileformat.Types+import Data.List (sort)+import Data.Word+import Control.Monad+import Data.Binary.Put+import Data.Foldable (for_, traverse_)+import Data.Traversable (for)+import qualified Data.ByteString as Strict++-- | This table allows multilingual strings to be associated with the+-- OpenType™ font file. These strings can represent copyright notices,+-- font names, family names, style names, and so on. To keep this+-- table short, the font manufacturer may wish to make a limited set+-- of entries in some small set of languages; later, the font can be+-- “localized” and the strings translated or added. Other parts of the+-- OpenType font file that require these strings can then refer to+-- them simply by their index number. Clients that need a particular+-- string can look it up by its platform ID, character encoding ID,+-- language ID and name ID. Note that some platforms may require+-- single byte character strings, while others may require double byte+-- strings.+--+-- For historical reasons, some applications which install fonts+-- perform version control using Macintosh platform (platform ID 1)+-- strings from the 'name' table. Because of this, it is strongly+-- recommended that the 'name' table of all fonts include Macintosh+-- platform strings and that the syntax of the version number (name id+-- 5) follows the guidelines given in the opentype specification.+--+-- The encoding for each bytestring depends on the PlatformID and+-- encodingID. This library doesn't do any conversion. For more+-- information see the opentype specification:+-- https://www.microsoft.com/typography/otspec/name.htm+data NameTable = NameTable [NameRecord]+ deriving Show++data NameRecord = NameRecord {+ namePlatform :: PlatformID,+ nameEncoding :: Word16,+ nameLanguage :: Word16,+ nameID :: Word16,+ nameString :: Strict.ByteString}+ deriving Show++instance Ord NameRecord where+ compare (NameRecord pID eID lang nID _)+ (NameRecord pID2 eID2 lang2 nID2 _) =+ compare (pID, eID, lang, nID) (pID2, eID2, lang2, nID2)++instance Eq NameRecord where+ (NameRecord pID eID lang nID _) ==+ (NameRecord pID2 eID2 lang2 nID2 _) =+ (pID, eID, lang, nID) == (pID2, eID2, lang2, nID2) ++putNameTable :: NameTable -> Put+putNameTable (NameTable records_) = do+ putWord16be 0+ putWord16be $ fromIntegral len+ putWord16be $ fromIntegral $ len * 12 + 6+ for_ (zip offsets records) $ \(offset, r) -> do+ putPf $ namePlatform r+ putWord16be $ nameEncoding r+ putWord16be $ nameLanguage r+ putWord16be $ nameID r+ putWord16be $ fromIntegral $ Strict.length $ nameString r+ putWord16be offset+ traverse_ (putByteString.nameString) records+ where len = length records+ records = sort records_+ lengths = map (fromIntegral . Strict.length . nameString) records+ offsets = scanl (+) 0 lengths++readNameTable :: Strict.ByteString -> Either String NameTable+readNameTable bs = do+ version <- index16 bs 0+ when (version > 0) $ fail "Unsupported name table format."+ len <- index16 bs 1 + storage <- index16 bs 2+ records <- for [0..len-1] $ \i -> do+ pf <- toPf =<< index16 bs (3 + i*6)+ enc <- index16 bs $ 3 + i*6 + 1+ lang <- index16 bs $ 3 + i*6 + 2+ nID <- index16 bs $ 3 + i*6 + 3+ len2 <- index16 bs $ 3 + i*6 + 4 + offset <- index16 bs $ 3 + i*6 + 5+ Right (offset, len2, NameRecord pf enc lang nID)+ records2 <- for records $+ \(offset, len2, r) ->+ if storage+offset+len2 > fromIntegral (Strict.length bs)+ then Left "string storage bounds exceeded"+ else Right $ r (Strict.take (fromIntegral len2) $+ Strict.drop (fromIntegral $ offset+storage) bs)+ return $ NameTable records2
+ Opentype/Fileformat/OS2.hs view
@@ -0,0 +1,150 @@+module Opentype.Fileformat.OS2+where+import Data.Word+import Data.Int+import Data.Binary.Put+import Data.Binary.Get+import Control.Monad (when)++-- | The OS/2 table consists of a set of metrics that are required in+-- OpenType fonts. For a description of these fields see:+-- https://www.microsoft.com/typography/otspec/os2.htm+data OS2Table = OS2Table {+ os2version :: Word16,+ xAvgCharWidth :: Int16,+ usWeightClass :: Word16,+ usWidthClass :: Word16,+ fsType :: Word16,+ ySubscriptXSize :: Int16,+ ySubscriptYSize :: Int16,+ ySubscriptXOffset :: Int16,+ ySubscriptYOffset :: Int16,+ ySuperscriptXSize :: Int16,+ ySuperscriptYSize :: Int16,+ ySuperscriptXOffset :: Int16,+ ySuperscriptYOffset :: Int16,+ yStrikeoutSize :: Int16,+ yStrikeoutPosition :: Int16,+ bFamilyClass :: Int16,+ bFamilyType :: Int8,+ bSerifStyle :: Int8,+ bWeight :: Int8,+ bProportion :: Int8,+ bContrast :: Int8,+ bStrokeVariation :: Int8,+ bArmStyle :: Int8,+ bLetterform :: Int8,+ bMidline :: Int8,+ bXHeight :: Int8,+ ulUnicodeRange1 :: Word32,+ ulUnicodeRange2 :: Word32,+ ulUnicodeRange3 :: Word32,+ ulUnicodeRange4 :: Word32,+ achVendID :: Word32,+ fsSelection :: Word16,+ usFirstCharIndex :: Word16,+ usLastCharIndex :: Word16,+ sTypoAscender :: Int16,+ sTypoDescender :: Int16,+ sTypoLineGap :: Int16,+ usWinAscent :: Word16,+ usWinDescent :: Word16,+ ulCodePageRange1 :: Word32,+ ulCodePageRange2 :: Word32,+ sxHeight :: Int16,+ sCapHeight :: Int16,+ usDefaultChar :: Word16,+ usBreakChar :: Word16,+ usMaxContext :: Word16,+ usLowerOpticalPointSize :: Word16,+ usUpperOpticalPointSize :: Word16+ }+ deriving Show++getOS2Table :: Get OS2Table+getOS2Table = do+ version <- getWord16be+ partial1 <- OS2Table version <$> getInt16be+ <*> getWord16be <*> getWord16be <*> getWord16be+ <*> getInt16be <*> getInt16be <*> getInt16be+ <*> getInt16be <*> getInt16be <*> getInt16be+ <*> getInt16be <*> getInt16be <*> getInt16be+ <*> getInt16be <*> getInt16be <*> getInt8+ <*> getInt8 <*> getInt8 <*> getInt8 <*> getInt8+ <*> getInt8 <*> getInt8 <*> getInt8 <*> getInt8+ <*> getInt8 <*> getWord32be <*> getWord32be <*> getWord32be+ <*> getWord32be <*> getWord32be <*> getWord16be+ <*> getWord16be <*> getWord16be <*> getInt16be+ <*> getInt16be <*> getInt16be <*> getWord16be <*> getWord16be+ if version == 0 then+ return $ partial1 0 0 0 0 0 0 0 0 0+ else do+ partial2 <- partial1 <$> getWord32be <*> getWord32be+ if version == 1 then+ return $ partial2 0 0 0 0 0 0 0+ else do+ partial3 <- partial2 <$> getInt16be <*> getInt16be <*>+ getWord16be <*> getWord16be <*> getWord16be+ if version < 5 then+ return $ partial3 0 0+ else partial3 <$> getWord16be <*> getWord16be++putOS2Table :: OS2Table -> Put+putOS2Table (OS2Table version f2 f3 f4 f5 f6 f7 f8 f9 f10+ f11 f12 f13 f14 f15 f16 f17 f18 f19 f20+ f21 f22 f23 f24 f25 f26 f27 f28 f29 f30+ f31 f32 f33 f34 f35 f36 f37 f38 f39 f40+ f41 f42 f43 f44 f45 f46 f47 f48) =+ do putWord16be version+ putInt16be f2+ putWord16be f3+ putWord16be f4+ putWord16be f5+ putInt16be f6+ putInt16be f7+ putInt16be f8+ putInt16be f9+ putInt16be f10+ putInt16be f11+ putInt16be f12+ putInt16be f13+ putInt16be f14+ putInt16be f15+ putInt16be f16+ putInt8 f17+ putInt8 f18+ putInt8 f19+ putInt8 f20+ putInt8 f21+ putInt8 f22+ putInt8 f23+ putInt8 f24+ putInt8 f25+ putInt8 f26+ putWord32be f27+ putWord32be f28+ putWord32be f29+ putWord32be f30+ putWord32be f31+ putWord16be f32+ putWord16be f33+ putWord16be f34+ putInt16be f35+ putInt16be f36+ putInt16be f37+ putWord16be f38+ putWord16be f39+ when (version > 0) $ do+ putWord32be f40+ putWord32be f41+ when (version > 1) $ do+ putInt16be f42+ putInt16be f43+ putWord16be f44+ putWord16be f45+ putWord16be f46+ when (version > 4) $ do+ putWord16be f47+ putWord16be f48+ +
+ Opentype/Fileformat/Post.hs view
@@ -0,0 +1,135 @@+{-# LANGUAGE LambdaCase #-}+module Opentype.Fileformat.Post where+import Opentype.Fileformat.Types+import Data.Word+import Data.Char+import Data.Binary.Put+import Data.Binary.Get+import Data.Foldable+import Data.Traversable+import Control.Monad (replicateM, replicateM_, when)++data PostVersion =+ -- | The first 258 Glyphs have standard names+ PostTable1 |+ -- | Order of glyph names can be changed, and glyphs can have+ -- non-standard names.+ PostTable2 |+ -- | No glyph names+ PostTable3+ deriving (Eq, Show)++-- |This table contains additional information needed to use TrueType+-- or OpenType™ fonts on PostScript printers. This includes data for+-- the FontInfo dictionary entry and the PostScript names of all the+-- glyphs. For more information about PostScript names, see the Adobe+-- document Unicode and Glyph Names.+--+-- Versions 1.0, 2.0, and 2.5 refer to TrueType fonts and OpenType+-- fonts with TrueType data. OpenType fonts with TrueType data may+-- also use Version 3.0. OpenType fonts with CFF data use Version 3.0+-- only.+data PostTable = PostTable {+ postVersion :: PostVersion,+ -- | Italic angle in counter-clockwise degrees from the+ -- vertical. Zero for upright text, negative for text that leans to+ -- the right (forward).+ italicAngle :: Fixed,+ -- | suggested values for the underline thickness.+ underlinePosition :: FWord,+ -- | This is the suggested distance of the top of the underline from+ -- the baseline (negative values indicate below baseline).+ --+ -- The PostScript definition of this FontInfo dictionary key (the y+ -- coordinate of the center of the stroke) is not used for+ -- historical reasons. The value of the PostScript key may be+ -- calculated by subtracting half the underlineThickness from the+ -- value of this field.+ underlineThickness :: FWord,+ -- | Set to 0 if the font is proportionally spaced, non-zero if the+ -- font is not proportionally spaced (i.e. monospaced).+ isFixedPitch :: Word32,+ -- | Minimum memory usage when an OpenType font is downloaded. Set+ -- to 0 if unsure.+ minMemType42 :: Word32,+ -- | Maximum memory usage when an OpenType font is downloaded. Set+ -- to 0 if unsure.+ maxMemType42 :: Word32,+ -- | Minimum memory usage when an OpenType font is downloaded as a+ -- Type 1 font. Set to 0 if unsure.+ minMemType1 :: Word32,+ -- | Maximum memory usage when an OpenType font is downloaded as a+ -- Type 1 font. Set to 0 if unsure.+ maxMemType1 :: Word32,+ -- | Ordinal number of the glyph in 'post' string tables. For+ -- format 2.0 only.+ -- + -- If the name index is between 0 and 257, treat the name index as a+ -- glyph index in the Macintosh standard order. If the name index is+ -- between 258 and 65535, then subtract 258 and use that to index+ -- into the list of Pascal strings at the end of the table. Thus a+ -- given font may map some of its glyphs to the standard glyph+ -- names, and some to its own names.+ --+ -- If you do not want to associate a PostScript name with a+ -- particular glyph, use index number 0 which points to the name+ -- .notdef.+ glyphNameIndex :: [Int],+ -- | strings for indices 258 and upwards.+ postStrings :: [String]+ }+ deriving (Show)++getPostTable :: Get PostTable+getPostTable = do+ iVersion <- getWord32be+ version <- case iVersion of+ 0x00010000 -> return PostTable1+ 0x00020000 -> return PostTable2+ 0x00030000 -> return PostTable3+ _ -> fail "Unsupported post table version."+ itA <- getWord32be+ ulPos <- getInt16be+ ulThick <- getInt16be+ isFixed <- getWord32be+ min42 <- getWord32be+ max42 <- getWord32be+ min1 <- getWord32be+ max1 <- getWord32be+ if version /= PostTable2+ then return $ PostTable version itA ulPos+ ulThick isFixed min42 max42 min1 max1 [] []+ else do+ n <- fromIntegral <$> getWord16be+ gIndex <- replicateM n (fromIntegral <$> getWord16be)+ pStrings <- replicateM ((maximum gIndex+1)-258) $ do+ l <- fromIntegral <$> getWord8+ replicateM l ((chr.fromIntegral) <$> getWord8)+ return $ PostTable version itA ulPos+ ulThick isFixed min42 max42 min1 max1 gIndex pStrings++putPostTable :: PostTable -> Put+putPostTable table = do+ putWord32be $ case postVersion table of+ PostTable1 -> 0x00010000+ PostTable2 -> 0x00020000+ PostTable3 -> 0x00030000+ putWord32be $ italicAngle table+ putInt16be $ underlinePosition table+ putInt16be $ underlineThickness table+ putWord32be $ isFixedPitch table+ putWord32be $ minMemType42 table+ putWord32be $ maxMemType42 table+ putWord32be $ minMemType1 table+ putWord32be $ maxMemType1 table+ when (postVersion table == PostTable2) $ do+ let nameIndexLen = length (glyphNameIndex table)+ nameMax = maximum (glyphNameIndex table) + 1+ postLen = length (postStrings table)+ putWord16be $ fromIntegral nameIndexLen+ traverse_ (putWord16be.fromIntegral) $ glyphNameIndex table+ for_ (take (nameMax-258) $ postStrings table) $ \str -> do+ putWord8 $ fromIntegral $ length str+ traverse_ (putWord8.fromIntegral.ord) str+ replicateM_ (nameMax-258-postLen) (putWord8 0)+
+ Opentype/Fileformat/Types.hs view
@@ -0,0 +1,127 @@+module Opentype.Fileformat.Types where+import Data.Word+import Data.Int+import Data.Bits+import Data.Binary.Put+import Data.ByteString.Unsafe+import qualified Data.ByteString as Strict+import qualified Data.Map as M++-- | A ShortFrac is an 16 bit signed fixed number with a bias of+-- 14. This means it can represent numbers between 1.999 (0x7fff) and+-- -2.0 (0x8000). 1.0 is stored as 16384 (0x4000) and -1.0 is stored+-- as -16384 (0xc000). Efficient numeric instances are provided.+newtype ShortFrac = ShortFrac Int16+ +-- | signed fixed-point number+type Fixed = Word32+-- | FWord describes a quantity in FUnits, the smallest+-- measurable distance in em space.+type FWord = Int16+-- | UFWord describes a quantity in FUnits, the smallest measurable+-- distance in em space.+type UFWord = Word16+-- | the glyph index in the glyph table+type GlyphID = Word16++data PlatformID =+ UnicodePlatform |+ -- | /DEPRECATED/+ MacintoshPlatform |+ MicrosoftPlatform+ deriving (Ord, Eq, Show)+++type WordMap a = M.Map Word32 a+-- return larged power of 2 <= i +iLog2 :: Integral a => a -> a+iLog2 = iLog2' 0 where+ iLog2' base i+ | i > 0 = iLog2' (base+1) (i `quot` 2) + | otherwise = base-1++byteAt :: (Bits a, Num a) => a -> Int -> Bool+byteAt flag i = flag .&. 1 `shift` i /= 0+{-# SPECIALIZE byteAt :: Word8 -> Int -> Bool #-}+{-# SPECIALIZE byteAt :: Word16 -> Int -> Bool #-}++makeFlag :: [Bool] -> Word16+makeFlag l =+ fromIntegral $ sum $ zipWith (*) (iterate (*2) 1) $+ map fromEnum l++instance Num ShortFrac where+ (ShortFrac a) + (ShortFrac b) = ShortFrac $ a + b+ (ShortFrac a) - (ShortFrac b) = ShortFrac $ a - b+ (ShortFrac a) * (ShortFrac b) =+ ShortFrac $ fromIntegral (((fromIntegral a :: Int32) * (fromIntegral b :: Int32)) `shift` (-14))+ abs (ShortFrac a) = ShortFrac $ abs a+ fromInteger i = ShortFrac $ fromIntegral i `shift` 14+ signum (ShortFrac a) = fromIntegral $ signum a++instance Eq ShortFrac where+ (ShortFrac a) == (ShortFrac b) = a == b++instance Ord ShortFrac where+ compare (ShortFrac a) (ShortFrac b) = compare a b++instance Fractional ShortFrac where+ fromRational r =+ ShortFrac $ fromIntegral $ + floor ((r+2) * 0x4000) - (0x8000::Word16)+ (ShortFrac a) / (ShortFrac b) =+ ShortFrac $ fromIntegral $+ ((fromIntegral a :: Int32) `shift` 14) `quot` fromIntegral b++instance Show ShortFrac where+ show a = show (realToFrac a :: Float)++instance Real ShortFrac where+ toRational (ShortFrac a) =+ fromIntegral ((fromIntegral a::Word16) + 0x8000) / 0x4000 - 2++instance RealFrac ShortFrac where+ properFraction (ShortFrac a)+ | a < 0 && f /= 0 = (i+1, ShortFrac (-f))+ | otherwise = (i, ShortFrac f)+ where i = fromIntegral (((fromIntegral a :: Word16) + 0x8000) `shift` (-14)) - 2+ f = a .&. 0x3fff++putShortFrac :: ShortFrac -> Put+putShortFrac (ShortFrac a) = putInt16be a++putPf :: PlatformID -> Put+putPf UnicodePlatform = putWord16be 0+putPf MacintoshPlatform = putWord16be 1+putPf MicrosoftPlatform = putWord16be 3++toPf :: Word16 -> Either String PlatformID+toPf i =+ case i of+ 0 -> Right UnicodePlatform+ 1 -> Right MacintoshPlatform+ 3 -> Right MicrosoftPlatform+ j -> Left $ "unknown platformID " ++ show j++index16 :: Strict.ByteString -> Word16 -> Either String Word16+index16 bs i+ | Strict.length bs < fromIntegral ((i+1)*2) ||+ i < 0 = Left $ "Index " ++ show i ++ " out of Bounds"+ | otherwise = Right $ b1 * 256 + b2+ where+ b1, b2 :: Word16+ b1 = fromIntegral $ unsafeIndex bs (fromIntegral $ i*2)+ b2 = fromIntegral $ unsafeIndex bs (fromIntegral $ i*2 + 1)++index32 :: Strict.ByteString -> Word32 -> Either String Word32+index32 bs i+ | Strict.length bs < fromIntegral ((i+1)*4) ||+ i < 0 = Left $ "Index " ++ show i ++ " Out of Bounds"+ | otherwise = Right $ b1 `shift` 24 .|. b2 `shift` 16 .|. b3 `shift` 8 .|. b4+ where+ b1, b2, b3, b4 :: Word32+ b1 = fromIntegral $ unsafeIndex bs (fromIntegral $ i*4)+ b2 = fromIntegral $ unsafeIndex bs (fromIntegral $ i*4 + 1)+ b3 = fromIntegral $ unsafeIndex bs (fromIntegral $ i*4 + 2)+ b4 = fromIntegral $ unsafeIndex bs (fromIntegral $ i*4 + 3)+
+ Setup.lhs view
@@ -0,0 +1,6 @@+#!/usr/bin/runhaskell +> module Main where+> import Distribution.Simple+> main :: IO ()+> main = defaultMain+
+ opentype.cabal view
@@ -0,0 +1,46 @@+name: opentype+version: 0.0.1+cabal-version: >=1.8+build-type: Simple+license: BSD3+license-file: LICENSE+copyright: Kristof Bastiaensen (2014)+maintainer: Kristof Bastiaensen+stability: Very Unstable+bug-reports: https://github.com/kuribas/haskell-opentype/issues+synopsis: Opentype loading and writing+description: This library supports loading and writing of opentype files.+category: Typography+author: Kristof Bastiaensen+data-dir: ""+ +source-repository head+ type: git+ location: https://github.com/kuribas/haskell-opentype+ +library+ build-depends:+ base >=3 && <5, binary >=0.8.1.0,+ bytestring >0.10.0, containers >=0.5.3, ghc >=7.10.0, time >1.4.0,+ vector >=0.10, pretty-hex >=1.0+ exposed-modules: Opentype.Fileformat+ exposed: True+ buildable: True+ other-modules:+ Opentype.Fileformat.Types+ Opentype.Fileformat.Glyph+ Opentype.Fileformat.Cmap+ Opentype.Fileformat.Head+ Opentype.Fileformat.Hhea+ Opentype.Fileformat.Maxp+ Opentype.Fileformat.Name+ Opentype.Fileformat.Post+ Opentype.Fileformat.Kern+ Opentype.Fileformat.OS2+ ghc-options: -Wall+ +test-suite test+ type: exitcode-stdio-1.0+ main-is: test.hs+ buildable: True+ hs-source-dirs: tests
+ tests/test.hs view
@@ -0,0 +1,1 @@+main = return ()