commit 384e9e7bd3cc0acc0d82e40e9318b033fcb6a600 Author: Eugen Wissner Date: Mon Mar 13 10:51:25 2023 +0100 Initial commit diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..82a75d5 --- /dev/null +++ b/.gitignore @@ -0,0 +1,4 @@ +/dist-newstyle/ +/dist/ + +/fonts/ diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 index 0000000..3b28f69 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,3 @@ +# Revision history for fountainhead + +## Unreleased diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..a612ad9 --- /dev/null +++ b/LICENSE @@ -0,0 +1,373 @@ +Mozilla Public License Version 2.0 +================================== + +1. Definitions +-------------- + +1.1. "Contributor" + means each individual or legal entity that creates, contributes to + the creation of, or owns Covered Software. + +1.2. "Contributor Version" + means the combination of the Contributions of others (if any) used + by a Contributor and that particular Contributor's Contribution. + +1.3. "Contribution" + means Covered Software of a particular Contributor. + +1.4. "Covered Software" + means Source Code Form to which the initial Contributor has attached + the notice in Exhibit A, the Executable Form of such Source Code + Form, and Modifications of such Source Code Form, in each case + including portions thereof. + +1.5. "Incompatible With Secondary Licenses" + means + + (a) that the initial Contributor has attached the notice described + in Exhibit B to the Covered Software; or + + (b) that the Covered Software was made available under the terms of + version 1.1 or earlier of the License, but not also under the + terms of a Secondary License. + +1.6. "Executable Form" + means any form of the work other than Source Code Form. + +1.7. "Larger Work" + means a work that combines Covered Software with other material, in + a separate file or files, that is not Covered Software. + +1.8. "License" + means this document. + +1.9. "Licensable" + means having the right to grant, to the maximum extent possible, + whether at the time of the initial grant or subsequently, any and + all of the rights conveyed by this License. + +1.10. "Modifications" + means any of the following: + + (a) any file in Source Code Form that results from an addition to, + deletion from, or modification of the contents of Covered + Software; or + + (b) any new file in Source Code Form that contains any Covered + Software. + +1.11. "Patent Claims" of a Contributor + means any patent claim(s), including without limitation, method, + process, and apparatus claims, in any patent Licensable by such + Contributor that would be infringed, but for the grant of the + License, by the making, using, selling, offering for sale, having + made, import, or transfer of either its Contributions or its + Contributor Version. + +1.12. "Secondary License" + means either the GNU General Public License, Version 2.0, the GNU + Lesser General Public License, Version 2.1, the GNU Affero General + Public License, Version 3.0, or any later versions of those + licenses. + +1.13. "Source Code Form" + means the form of the work preferred for making modifications. + +1.14. "You" (or "Your") + means an individual or a legal entity exercising rights under this + License. For legal entities, "You" includes any entity that + controls, is controlled by, or is under common control with You. For + purposes of this definition, "control" means (a) the power, direct + or indirect, to cause the direction or management of such entity, + whether by contract or otherwise, or (b) ownership of more than + fifty percent (50%) of the outstanding shares or beneficial + ownership of such entity. + +2. License Grants and Conditions +-------------------------------- + +2.1. Grants + +Each Contributor hereby grants You a world-wide, royalty-free, +non-exclusive license: + +(a) under intellectual property rights (other than patent or trademark) + Licensable by such Contributor to use, reproduce, make available, + modify, display, perform, distribute, and otherwise exploit its + Contributions, either on an unmodified basis, with Modifications, or + as part of a Larger Work; and + +(b) under Patent Claims of such Contributor to make, use, sell, offer + for sale, have made, import, and otherwise transfer either its + Contributions or its Contributor Version. + +2.2. Effective Date + +The licenses granted in Section 2.1 with respect to any Contribution +become effective for each Contribution on the date the Contributor first +distributes such Contribution. + +2.3. Limitations on Grant Scope + +The licenses granted in this Section 2 are the only rights granted under +this License. No additional rights or licenses will be implied from the +distribution or licensing of Covered Software under this License. +Notwithstanding Section 2.1(b) above, no patent license is granted by a +Contributor: + +(a) for any code that a Contributor has removed from Covered Software; + or + +(b) for infringements caused by: (i) Your and any other third party's + modifications of Covered Software, or (ii) the combination of its + Contributions with other software (except as part of its Contributor + Version); or + +(c) under Patent Claims infringed by Covered Software in the absence of + its Contributions. + +This License does not grant any rights in the trademarks, service marks, +or logos of any Contributor (except as may be necessary to comply with +the notice requirements in Section 3.4). + +2.4. Subsequent Licenses + +No Contributor makes additional grants as a result of Your choice to +distribute the Covered Software under a subsequent version of this +License (see Section 10.2) or under the terms of a Secondary License (if +permitted under the terms of Section 3.3). + +2.5. Representation + +Each Contributor represents that the Contributor believes its +Contributions are its original creation(s) or it has sufficient rights +to grant the rights to its Contributions conveyed by this License. + +2.6. Fair Use + +This License is not intended to limit any rights You have under +applicable copyright doctrines of fair use, fair dealing, or other +equivalents. + +2.7. Conditions + +Sections 3.1, 3.2, 3.3, and 3.4 are conditions of the licenses granted +in Section 2.1. + +3. Responsibilities +------------------- + +3.1. Distribution of Source Form + +All distribution of Covered Software in Source Code Form, including any +Modifications that You create or to which You contribute, must be under +the terms of this License. You must inform recipients that the Source +Code Form of the Covered Software is governed by the terms of this +License, and how they can obtain a copy of this License. You may not +attempt to alter or restrict the recipients' rights in the Source Code +Form. + +3.2. Distribution of Executable Form + +If You distribute Covered Software in Executable Form then: + +(a) such Covered Software must also be made available in Source Code + Form, as described in Section 3.1, and You must inform recipients of + the Executable Form how they can obtain a copy of such Source Code + Form by reasonable means in a timely manner, at a charge no more + than the cost of distribution to the recipient; and + +(b) You may distribute such Executable Form under the terms of this + License, or sublicense it under different terms, provided that the + license for the Executable Form does not attempt to limit or alter + the recipients' rights in the Source Code Form under this License. + +3.3. Distribution of a Larger Work + +You may create and distribute a Larger Work under terms of Your choice, +provided that You also comply with the requirements of this License for +the Covered Software. If the Larger Work is a combination of Covered +Software with a work governed by one or more Secondary Licenses, and the +Covered Software is not Incompatible With Secondary Licenses, this +License permits You to additionally distribute such Covered Software +under the terms of such Secondary License(s), so that the recipient of +the Larger Work may, at their option, further distribute the Covered +Software under the terms of either this License or such Secondary +License(s). + +3.4. Notices + +You may not remove or alter the substance of any license notices +(including copyright notices, patent notices, disclaimers of warranty, +or limitations of liability) contained within the Source Code Form of +the Covered Software, except that You may alter any license notices to +the extent required to remedy known factual inaccuracies. + +3.5. Application of Additional Terms + +You may choose to offer, and to charge a fee for, warranty, support, +indemnity or liability obligations to one or more recipients of Covered +Software. However, You may do so only on Your own behalf, and not on +behalf of any Contributor. You must make it absolutely clear that any +such warranty, support, indemnity, or liability obligation is offered by +You alone, and You hereby agree to indemnify every Contributor for any +liability incurred by such Contributor as a result of warranty, support, +indemnity or liability terms You offer. You may include additional +disclaimers of warranty and limitations of liability specific to any +jurisdiction. + +4. Inability to Comply Due to Statute or Regulation +--------------------------------------------------- + +If it is impossible for You to comply with any of the terms of this +License with respect to some or all of the Covered Software due to +statute, judicial order, or regulation then You must: (a) comply with +the terms of this License to the maximum extent possible; and (b) +describe the limitations and the code they affect. Such description must +be placed in a text file included with all distributions of the Covered +Software under this License. Except to the extent prohibited by statute +or regulation, such description must be sufficiently detailed for a +recipient of ordinary skill to be able to understand it. + +5. Termination +-------------- + +5.1. The rights granted under this License will terminate automatically +if You fail to comply with any of its terms. However, if You become +compliant, then the rights granted under this License from a particular +Contributor are reinstated (a) provisionally, unless and until such +Contributor explicitly and finally terminates Your grants, and (b) on an +ongoing basis, if such Contributor fails to notify You of the +non-compliance by some reasonable means prior to 60 days after You have +come back into compliance. Moreover, Your grants from a particular +Contributor are reinstated on an ongoing basis if such Contributor +notifies You of the non-compliance by some reasonable means, this is the +first time You have received notice of non-compliance with this License +from such Contributor, and You become compliant prior to 30 days after +Your receipt of the notice. + +5.2. If You initiate litigation against any entity by asserting a patent +infringement claim (excluding declaratory judgment actions, +counter-claims, and cross-claims) alleging that a Contributor Version +directly or indirectly infringes any patent, then the rights granted to +You by any and all Contributors for the Covered Software under Section +2.1 of this License shall terminate. + +5.3. In the event of termination under Sections 5.1 or 5.2 above, all +end user license agreements (excluding distributors and resellers) which +have been validly granted by You or Your distributors under this License +prior to termination shall survive termination. + +************************************************************************ +* * +* 6. Disclaimer of Warranty * +* ------------------------- * +* * +* Covered Software is provided under this License on an "as is" * +* basis, without warranty of any kind, either expressed, implied, or * +* statutory, including, without limitation, warranties that the * +* Covered Software is free of defects, merchantable, fit for a * +* particular purpose or non-infringing. The entire risk as to the * +* quality and performance of the Covered Software is with You. * +* Should any Covered Software prove defective in any respect, You * +* (not any Contributor) assume the cost of any necessary servicing, * +* repair, or correction. This disclaimer of warranty constitutes an * +* essential part of this License. No use of any Covered Software is * +* authorized under this License except under this disclaimer. * +* * +************************************************************************ + +************************************************************************ +* * +* 7. Limitation of Liability * +* -------------------------- * +* * +* Under no circumstances and under no legal theory, whether tort * +* (including negligence), contract, or otherwise, shall any * +* Contributor, or anyone who distributes Covered Software as * +* permitted above, be liable to You for any direct, indirect, * +* special, incidental, or consequential damages of any character * +* including, without limitation, damages for lost profits, loss of * +* goodwill, work stoppage, computer failure or malfunction, or any * +* and all other commercial damages or losses, even if such party * +* shall have been informed of the possibility of such damages. This * +* limitation of liability shall not apply to liability for death or * +* personal injury resulting from such party's negligence to the * +* extent applicable law prohibits such limitation. Some * +* jurisdictions do not allow the exclusion or limitation of * +* incidental or consequential damages, so this exclusion and * +* limitation may not apply to You. * +* * +************************************************************************ + +8. Litigation +------------- + +Any litigation relating to this License may be brought only in the +courts of a jurisdiction where the defendant maintains its principal +place of business and such litigation shall be governed by laws of that +jurisdiction, without reference to its conflict-of-law provisions. +Nothing in this Section shall prevent a party's ability to bring +cross-claims or counter-claims. + +9. Miscellaneous +---------------- + +This License represents the complete agreement concerning the subject +matter hereof. If any provision of this License is held to be +unenforceable, such provision shall be reformed only to the extent +necessary to make it enforceable. Any law or regulation which provides +that the language of a contract shall be construed against the drafter +shall not be used to construe this License against a Contributor. + +10. Versions of the License +--------------------------- + +10.1. New Versions + +Mozilla Foundation is the license steward. Except as provided in Section +10.3, no one other than the license steward has the right to modify or +publish new versions of this License. Each version will be given a +distinguishing version number. + +10.2. Effect of New Versions + +You may distribute the Covered Software under the terms of the version +of the License under which You originally received the Covered Software, +or under the terms of any subsequent version published by the license +steward. + +10.3. Modified Versions + +If you create software not governed by this License, and you want to +create a new license for such software, you may create and use a +modified version of this License if you rename the license and remove +any references to the name of the license steward (except to note that +such modified license differs from this License). + +10.4. Distributing Source Code Form that is Incompatible With Secondary +Licenses + +If You choose to distribute Source Code Form that is Incompatible With +Secondary Licenses under the terms of this version of the License, the +notice described in Exhibit B of this License must be attached. + +Exhibit A - Source Code Form License Notice +------------------------------------------- + + This Source Code Form is subject to the terms of the Mozilla Public + License, v. 2.0. If a copy of the MPL was not distributed with this + file, You can obtain one at http://mozilla.org/MPL/2.0/. + +If it is not possible or desirable to put the notice in a particular +file, then You may include the notice in a location (such as a LICENSE +file in a relevant directory) where a recipient would be likely to look +for such a notice. + +You may add additional accurate notices of copyright ownership. + +Exhibit B - "Incompatible With Secondary Licenses" Notice +--------------------------------------------------------- + + This Source Code Form is "Incompatible With Secondary Licenses", as + defined by the Mozilla Public License, v. 2.0. diff --git a/README.txt b/README.txt new file mode 100644 index 0000000..d3038fa --- /dev/null +++ b/README.txt @@ -0,0 +1 @@ +TrueType font parser. diff --git a/fountainhead.cabal b/fountainhead.cabal new file mode 100644 index 0000000..b0c2662 --- /dev/null +++ b/fountainhead.cabal @@ -0,0 +1,35 @@ +cabal-version: 2.4 +name: fountainhead +version: 0.1.0.0 + +synopsis: TrueType font parser +description: TrueType font parseer. +bug-reports: https://git.caraus.tech/OSS/fountainhead + +license-files: LICENSE +license: MPL-2.0 + +author: Eugen Wissner +maintainer: belka@caraus.de + +copyright: (c) 2023 Eugen Wissner +category: Graphics + +extra-source-files: + CHANGELOG.md + README.txt + +library + exposed-modules: + Graphics.Fountainhead.Parser + Graphics.Fountainhead.Type + Graphics.Fountainhead.TrueType + hs-source-dirs: + src + build-depends: + base ^>=4.16.3.0, + bytestring ^>= 0.11.0, + containers ^>= 0.6.5, + megaparsec ^>= 9.3, + time ^>= 1.12, + vector ^>= 0.13.0 diff --git a/src/Graphics/Fountainhead/Parser.hs b/src/Graphics/Fountainhead/Parser.hs new file mode 100644 index 0000000..bfa1596 --- /dev/null +++ b/src/Graphics/Fountainhead/Parser.hs @@ -0,0 +1,1198 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE TypeApplications #-} + +-- | Font parser. +module Graphics.Fountainhead.Parser + ( cmapTableP + , cvTableP + , f2Dot14P + , fixedP + , fontDirectoryP + , fpgmTableP + , glyfTableP + , hdmxTableP + , headTableP + , hheaTableP + , hmtxTableP + , longDateTimeP + , longLocaTableP + , maxpTableP + , nameTableP + , os2TableP + , panoseP + , parseTable + , pascalStringP + , postTableP + , prepTableP + , shortLocaTableP + , word24P + ) where + +import Control.Applicative (Alternative(..)) +import Control.Monad (foldM) +import Data.Bits (Bits(..)) +import Data.ByteString (ByteString) +import qualified Data.ByteString as ByteString +import qualified Data.ByteString.Builder as ByteString.Builder +import qualified Data.ByteString.Lazy as ByteString.Lazy +import Data.Foldable (Foldable(..)) +import Data.Int (Int8, Int16) +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap +import Data.Functor (($>)) +import Data.List (nub, sort, sortOn, nubBy, sortBy) +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Maybe (fromMaybe) +import Data.Time + ( LocalTime(..) + , TimeOfDay(..) + , addDays + , secondsToDiffTime + , timeToTimeOfDay + ) +import Data.Time.Calendar.OrdinalDate (fromOrdinalDate) +import Data.Vector (Vector) +import qualified Data.Vector as Vector +import Data.Void (Void) +import Data.Word (Word8, Word16, Word32) +import GHC.Records (HasField(..)) +import Graphics.Fountainhead.TrueType + ( BArmStyle(..) + , BContrast(..) + , BFamilyType(..) + , BMidline(..) + , BLetterform(..) + , BProportion(..) + , BSerifStyle(..) + , BStrokeVariation(..) + , BWeight(..) + , BXHeight(..) + , CVTable(..) + , CmapSubtable(..) + , CmapTable(..) + , CmapEncoding(..) + , CmapFormat0Table(..) + , CmapFormat2Subheader(..) + , CmapFormat2Table(..) + , CmapFormat4Table(..) + , CmapFormat6Table(..) + , CmapGroup(..) + , CmapFormat8Table(..) + , CmapFormat10Table(..) + , CmapFormat12Table(..) + , CmapFormat13Table + , CmapFormat14Table(..) + , ComponentGlyphFlags(..) + , ComponentGlyphPartDescription(..) + , CompoundGlyphDefinition(..) + , FpgmTable(..) + , FontDirectionHint(..) + , FontDirectory(..) + , FontStyle(..) + , GlyfTable(..) + , GlyphArgument(..) + , GlyphCoordinate(..) + , GlyphDefinition(..) + , GlyphDescription(..) + , GlyphTransformationOption(..) + , HdmxTable(..) + , DeviceRecord(..) + , HeadTable(..) + , HheaTable(..) + , HmtxTable(..) + , LocaTable(..) + , LongHorMetric(..) + , MaxpTable(..) + , NameRecord(..) + , NameTable(..) + , OffsetSubtable(..) + , OutlineFlag(..) + , OpenMaxpTable(..) + , Os2BaseFields(..) + , Os2MicrosoftFields(..) + , Os2Version1Fields(..) + , Os2Version4Fields(..) + , Os2Version5Fields(..) + , Os2Table(..) + , Panose(..) + , PostFormat2Table(..) + , PostHeader(..) + , PostSubtable(..) + , PostTable(..) + , PrepTable(..) + , SimpleGlyphDefinition(..) + , TableDirectory(..) + , TrueMaxpTable(..) + , UVSOffset(..) + , UVSMapping(..) + , UnicodeValueRange(..) + , VariationSelectorMap + , unLocaTable + ) +import Graphics.Fountainhead.Type (F2Dot14(..), Fixed32(..)) +import Text.Megaparsec (()) +import qualified Text.Megaparsec as Megaparsec +import qualified Text.Megaparsec.Byte.Binary as Megaparsec.Binary + +type Parser = Megaparsec.Parsec Void ByteString + +-- * Font directory + +offsetSubtableP :: Parser OffsetSubtable +offsetSubtableP = OffsetSubtable + <$> Megaparsec.Binary.word32be + <*> (fromIntegral <$> Megaparsec.Binary.word16be) + <*> Megaparsec.Binary.word16be + <*> Megaparsec.Binary.word16be + <*> Megaparsec.Binary.word16be + +tagP :: Parser ByteString +tagP = ByteString.Lazy.toStrict + . ByteString.Builder.toLazyByteString + . ByteString.Builder.word32BE + <$> Megaparsec.Binary.word32be + +tableDirectoryP :: Parser TableDirectory +tableDirectoryP = TableDirectory + <$> tagP + <*> Megaparsec.Binary.word32be + <*> (fromIntegral <$> Megaparsec.Binary.word32be) + <*> (fromIntegral <$> Megaparsec.Binary.word32be) + +fontDirectoryP :: Parser FontDirectory +fontDirectoryP = do + offsetSubtable'@OffsetSubtable{ numTables } <- offsetSubtableP + tableDirectories <- Megaparsec.count numTables tableDirectoryP + pure $ FontDirectory + { offsetSubtable = offsetSubtable' + , tableDirectory = tableDirectories + } + +-- * Name table + +nameTableP :: Parser NameTable +nameTableP = do + format' <- Megaparsec.Binary.word16be + count' <- fromIntegral <$> Megaparsec.Binary.word16be + stringOffset' <- fromIntegral <$> Megaparsec.Binary.word16be + nameRecord' <- Megaparsec.count count' nameRecordP + -- 12 is the size of a single record, 6 is the header size. + let padding = stringOffset' - count' * 12 - 6 + Megaparsec.skipCount padding Megaparsec.Binary.word8 + variable' <- Megaparsec.takeRest + pure $ NameTable + { format = format' + , nameRecord = nameRecord' + , variable = parseVariable variable' <$> nameRecord' + } + where + parseVariable variable' NameRecord{ offset, length } = + ByteString.take length $ ByteString.drop offset variable' + +nameRecordP :: Parser NameRecord +nameRecordP = NameRecord + <$> Megaparsec.Binary.word16be + <*> Megaparsec.Binary.word16be + <*> Megaparsec.Binary.word16be + <*> Megaparsec.Binary.word16be + <*> (fromIntegral <$> Megaparsec.Binary.word16be) + <*> (fromIntegral <$> Megaparsec.Binary.word16be) + +-- * 'cvt ' table + +cvTableP :: Parser CVTable +cvTableP = CVTable + <$> Megaparsec.many Megaparsec.Binary.int16be + <* Megaparsec.eof + +-- * Maximum profile table + +trueMaxpTableP :: Parser TrueMaxpTable +trueMaxpTableP + = Megaparsec.chunk (ByteString.pack [0, 1, 0, 0]) + *> subparser + where + subparser = + TrueMaxpTable (Fixed32 0x00010000) + <$> Megaparsec.Binary.word16be + <*> Megaparsec.Binary.word16be + <*> Megaparsec.Binary.word16be + <*> Megaparsec.Binary.word16be + <*> Megaparsec.Binary.word16be + <*> Megaparsec.Binary.word16be + <*> Megaparsec.Binary.word16be + <*> Megaparsec.Binary.word16be + <*> Megaparsec.Binary.word16be + <*> Megaparsec.Binary.word16be + <*> Megaparsec.Binary.word16be + <*> Megaparsec.Binary.word16be + <*> Megaparsec.Binary.word16be + <*> Megaparsec.Binary.word16be + +openMaxpTableP :: Parser OpenMaxpTable +openMaxpTableP + = Megaparsec.chunk (ByteString.pack [0, 0, 0x50, 0]) + *> subparser + where + subparser = + OpenMaxpTable (Fixed32 0x00005000) + <$> Megaparsec.Binary.word16be + <* Megaparsec.eof + +maxpTableP :: Parser MaxpTable +maxpTableP + = TrueMaxp <$> trueMaxpTableP + <|> OpenMaxp <$> openMaxpTableP + +-- * Horizontal header table + +hheaTableP :: Parser HheaTable +hheaTableP = HheaTable + <$> fixedP + <*> Megaparsec.Binary.int16be + <*> Megaparsec.Binary.int16be + <*> Megaparsec.Binary.int16be + <*> Megaparsec.Binary.word16be + <*> Megaparsec.Binary.word16be + <*> Megaparsec.Binary.word16be + <*> Megaparsec.Binary.word16be + <*> Megaparsec.Binary.int16be + <*> Megaparsec.Binary.int16be + <*> Megaparsec.Binary.int16be + <* Megaparsec.Binary.int16be + <* Megaparsec.Binary.int16be + <* Megaparsec.Binary.int16be + <* Megaparsec.Binary.int16be + <*> Megaparsec.Binary.int16be + <*> Megaparsec.Binary.word16be + <* Megaparsec.eof + +-- * Font header table + +headTableP :: Parser HeadTable +headTableP = HeadTable + <$> fixedP + <*> fixedP + <*> Megaparsec.Binary.word32be + <*> Megaparsec.Binary.word32be + <*> Megaparsec.Binary.word16be + <*> Megaparsec.Binary.word16be + <*> longDateTimeP + <*> longDateTimeP + <*> Megaparsec.Binary.int16be + <*> Megaparsec.Binary.int16be + <*> Megaparsec.Binary.int16be + <*> Megaparsec.Binary.int16be + <*> fontStyleP + <*> Megaparsec.Binary.word16be + <*> fontDirectionHintP + <*> Megaparsec.Binary.word16be + <*> Megaparsec.Binary.word16be + <* Megaparsec.eof + +fontStyleP :: Parser FontStyle +fontStyleP = go <$> Megaparsec.Binary.word16be + where + go fontStyle' = FontStyle + { bold = testBit fontStyle' 0 + , italic = testBit fontStyle' 1 + , underline = testBit fontStyle' 2 + , outline = testBit fontStyle' 3 + , shadow = testBit fontStyle' 4 + , condensed = testBit fontStyle' 5 + , extended = testBit fontStyle' 6 + } + +fontDirectionHintP :: Parser FontDirectionHint +fontDirectionHintP + = (Megaparsec.chunk (ByteString.pack [0, 0]) $> MixedDirectionalGlyphs) + <|> (Megaparsec.chunk (ByteString.pack [0, 1]) $> StronglyLeftToRightGlyphs) + <|> (Megaparsec.chunk (ByteString.pack [0, 2]) $> LeftToRightGlyphsWithNeutrals) + <|> (Megaparsec.chunk (ByteString.pack [0xff, 0xff]) $> StronglyRightToLeftGlyphs) + <|> (Megaparsec.chunk (ByteString.pack [0xff, 0xfe]) $> RightToLeftGlyphsWithNeutrals) + +-- * Glyph data location table + +longLocaTableP :: Parser LocaTable +longLocaTableP = LongLocaTable + <$> vectorP Megaparsec.Binary.word32be + "loca table, long version" + +shortLocaTableP :: Parser LocaTable +shortLocaTableP = ShortLocaTable + <$> vectorP Megaparsec.Binary.word16be + "loca table, short version" + +-- * Horizontal metrics table + +longHorMetricP :: Parser LongHorMetric +longHorMetricP = LongHorMetric + <$> Megaparsec.Binary.word16be + <*> Megaparsec.Binary.int16be + +hmtxTableP :: Int -> Parser HmtxTable +hmtxTableP numOfLongHorMetrics = HmtxTable + <$> countP numOfLongHorMetrics longHorMetricP + <*> Megaparsec.many Megaparsec.Binary.int16be + +-- * Glyph name and PostScript font table + +postTableP :: Parser PostTable +postTableP = do + header'@PostHeader{ format } <- postHeaderP + subtable' <- case format of + Fixed32 0x00010000 -> pure None + Fixed32 0x00020000 -> PostFormat2 <$> postFormat2TableP + Fixed32 0x00025000 -> PostFormat25 <$> postFormat25TableP + Fixed32 0x00030000 -> pure None + Fixed32 0x00040000 -> PostFormat4 <$> postFormat4TableP + _ -> fail $ "Unsupported post table format: " <> show format + Megaparsec.eof + pure $ PostTable + { postHeader = header' + , postSubtable = subtable' + } + +postFormat2TableP :: Parser PostFormat2Table +postFormat2TableP = do + numberOfGlyphs <- fromIntegral <$> Megaparsec.Binary.word16be + glyphNameIndex' <- Megaparsec.count numberOfGlyphs Megaparsec.Binary.word16be + rest <- Megaparsec.many pascalStringP + pure $ PostFormat2Table + { glyphNameIndex = Vector.fromList glyphNameIndex' + , names = Vector.fromList rest + } + +postFormat25TableP :: Parser (Vector Int8) +postFormat25TableP = Megaparsec.Binary.word16be + >>= fmap Vector.fromList + . flip Megaparsec.count Megaparsec.Binary.int8 + . fromIntegral + +postFormat4TableP :: Parser (Vector Word16) +postFormat4TableP = Vector.fromList + <$> Megaparsec.many Megaparsec.Binary.word16be + +postHeaderP :: Parser PostHeader +postHeaderP = PostHeader + <$> fixedP + <*> fixedP + <*> Megaparsec.Binary.int16be + <*> Megaparsec.Binary.int16be + <*> Megaparsec.Binary.word32be + <*> Megaparsec.Binary.word32be + <*> Megaparsec.Binary.word32be + <*> Megaparsec.Binary.word32be + <*> Megaparsec.Binary.word32be + +-- * Font program table + +fpgmTableP :: Parser FpgmTable +fpgmTableP = FpgmTable + <$> vectorP Megaparsec.Binary.word8 + +-- * Prep table + +prepTableP :: Parser PrepTable +prepTableP = PrepTable + <$> vectorP Megaparsec.Binary.word8 + +-- * Horizontal device metrics table + +deviceRecordP :: Int -> Parser DeviceRecord +deviceRecordP size = do + pixelSize' <- Megaparsec.Binary.word8 + maximumWidth' <- Megaparsec.Binary.word8 + widths' <- vectorNP size Megaparsec.Binary.word8 + let paddingLength = 4 - ((Vector.length widths' + 2) `mod` 4) + Megaparsec.skipCount paddingLength + $ Megaparsec.chunk + $ ByteString.pack [0] + pure $ DeviceRecord + { pixelSize = pixelSize' + , maximumWidth = maximumWidth' + , widths = widths' + } + +hdmxTableP :: Parser HdmxTable +hdmxTableP = do + Megaparsec.chunk $ ByteString.pack [0, 0] + numberOfDeviceRecords <- fromIntegral <$> Megaparsec.Binary.int16be + sizeOfDeviceRecord <- fromIntegral <$> Megaparsec.Binary.int32be + records' <- Megaparsec.count numberOfDeviceRecords + $ deviceRecordP sizeOfDeviceRecord + Megaparsec.eof >> pure (HdmxTable 0 records') + +-- * Glyph outline table + +glyphDescriptionP :: Parser GlyphDescription +glyphDescriptionP = do + numberOfContours' <- fromIntegral + <$> Megaparsec.Binary.int16be + "numberOfContours" + xMin' <- Megaparsec.Binary.int16be "xMin" + yMin' <- Megaparsec.Binary.int16be "yMin" + xMax' <- Megaparsec.Binary.int16be "xMax" + yMax' <- Megaparsec.Binary.int16be "yMax" + glyphDefinition <- + if numberOfContours' >= 0 + then SimpleGlyph <$> simpleGlyphDefinitionP numberOfContours' + else CompoundGlyph <$> compoundGlyphDefinitionP + pure $ GlyphDescription + { numberOfContours = numberOfContours' + , xMin = xMin' + , yMin = yMin' + , xMax = xMax' + , yMax = yMax' + , definition = glyphDefinition + } + +glyphInstructionsP :: Parser (Vector Word8) +glyphInstructionsP = Megaparsec.Binary.word16be + >>= flip vectorNP (Megaparsec.Binary.word8 "compound glyph instruction") + . fromIntegral + +compoundGlyphDefinitionP :: Parser CompoundGlyphDefinition +compoundGlyphDefinitionP = do + components' <- componentGlyphPartDescriptionP mempty + let instructions' = + if Vector.any (weHaveInstructions . getField @"flags") components' + then glyphInstructionsP + else pure mempty + CompoundGlyphDefinition components' <$> instructions' + +componentGlyphPartDescriptionP + ::Vector ComponentGlyphPartDescription + -> Parser (Vector ComponentGlyphPartDescription) +componentGlyphPartDescriptionP accumulator = do + flags' <- Megaparsec.Binary.word16be "flags" + glyphIndex' <- Megaparsec.Binary.word16be "glyphIndex" + let arg1And2AreWords = testBit flags' 0 + argsAreXyValues = testBit flags' 1 + weHaveAScale = testBit flags' 3 + weHaveAnXAndYScale = testBit flags' 6 + weHaveATwoByTwo = testBit flags' 7 + argument1 <- glyphArgumentP arg1And2AreWords argsAreXyValues "argument1" + argument2 <- glyphArgumentP arg1And2AreWords argsAreXyValues "argument2" + transformationOption' <- transformationOptionP weHaveAScale weHaveAnXAndYScale weHaveATwoByTwo + "transformation option" + + let updated = Vector.snoc accumulator $ ComponentGlyphPartDescription + { flags = ComponentGlyphFlags + { roundXyToGrid = testBit flags' 2 + , weHaveInstructions = testBit flags' 8 + , useMyMetrics = testBit flags' 9 + , overlapCompound = testBit flags' 10 + } + , glyphIndex = glyphIndex' + , argument1 = argument1 + , argument2 = argument2 + , transformationOption = transformationOption' + } + -- MORE_COMPONENTS. + if testBit flags' 5 then componentGlyphPartDescriptionP updated else pure updated + +transformationOptionP :: Bool -> Bool -> Bool -> Parser GlyphTransformationOption +transformationOptionP True _ _ = GlyphScale <$> f2Dot14P "scale" +transformationOptionP _ True _ = GlyphXyScale + <$> f2Dot14P + <*> f2Dot14P + "xy-scale" +transformationOptionP _ _ True = Glyph2By2Scale + <$> f2Dot14P + <*> f2Dot14P + <*> f2Dot14P + <*> f2Dot14P + "2 by 2 transformation" +transformationOptionP _ _ _ = pure GlyphNoScale + +glyphArgumentP :: Bool -> Bool -> Parser GlyphArgument +glyphArgumentP True True = GlyphInt16Argument + <$> Megaparsec.Binary.int16be + "int16 argument" +glyphArgumentP True False = GlyphWord16Argument + <$> Megaparsec.Binary.word16be + "uint16 argument" +glyphArgumentP False True = GlyphInt8Argument + <$> Megaparsec.Binary.int8 + "int8 argument" +glyphArgumentP False False = GlyphWord8Argument + <$> Megaparsec.Binary.word8 + "uint8 argument" + +simpleGlyphDefinitionP :: Int -> Parser SimpleGlyphDefinition +simpleGlyphDefinitionP numberOfContours' = do + endPtsOfContours' <- vectorNP numberOfContours' Megaparsec.Binary.word16be + "endPtsOfContours" + let numberOfPoints = + if Vector.null endPtsOfContours' + then 0 + else fromIntegral $ Vector.last endPtsOfContours' + instructionLength <- fromIntegral + <$> Megaparsec.Binary.word16be + "instructionLength" + instructions' <- vectorNP instructionLength + (Megaparsec.Binary.word8 "simple glyph instruction") + flags' <- flagsP numberOfPoints mempty "flags" + xs <- Vector.foldM (coordinateP xFlagPair) mempty flags' + ys <- Vector.foldM (coordinateP yFlagPair) mempty flags' + pure $ SimpleGlyphDefinition + { endPtsOfContours = endPtsOfContours' + , instructions = instructions' + , coordinates = mkCoordinate <$> Vector.zip3 xs ys flags' + } + where + mkCoordinate (x, y, OutlineFlag{ onCurve }) = GlyphCoordinate x y onCurve + xFlagPair :: OutlineFlag -> (Bool, Bool) + xFlagPair OutlineFlag{ xShortVector, thisXIsSame } = + (xShortVector, thisXIsSame) + yFlagPair :: OutlineFlag -> (Bool, Bool) + yFlagPair OutlineFlag{ yShortVector, thisYIsSame } = + (yShortVector, thisYIsSame) + coordinateP + :: (OutlineFlag -> (Bool, Bool)) + -> Vector Int16 + -> OutlineFlag + -> Parser (Vector Int16) + coordinateP get accumulator first = + case get first of + (True, True) -> Vector.snoc accumulator . fromIntegral + <$> Megaparsec.Binary.word8 + "1 byte long positive coordinate" + (True, False) + -> Vector.snoc accumulator . negate . fromIntegral + <$> Megaparsec.Binary.word8 + "1 byte long negative coordinate" + (False, False) -> Vector.snoc accumulator + <$> Megaparsec.Binary.int16be + "2 bytes long coordinate" + (False, True) -> pure $ Vector.snoc accumulator 0 + flagsP :: Int -> Vector OutlineFlag -> Parser (Vector OutlineFlag) + flagsP remaining accumulator + | remaining < 0 = pure accumulator + | otherwise = do + flag <- Megaparsec.Binary.word8 "outline flags" + let flag' = OutlineFlag + { onCurve = testBit flag 0 + , xShortVector = testBit flag 1 + , yShortVector = testBit flag 2 + , thisXIsSame = testBit flag 4 + , thisYIsSame = testBit flag 5 + } + repeat = testBit flag 3 + repeatN <- + if repeat + then (1 +) + . fromIntegral + <$> Megaparsec.Binary.word8 + "flag repeat count" + else pure 1 + flagsP (remaining - repeatN) + $ accumulator <> Vector.replicate repeatN flag' + +glyfTableP :: LocaTable -> Parser GlyfTable +glyfTableP locaTable + | locaTable' <- unLocaTable locaTable + , not $ Vector.null locaTable' = + let locaInit = Vector.init locaTable' + offsets = traverse go + $ nubBy duplicate + $ sortOn fst + $ filter filterNullLength + $ Vector.toList + $ Vector.zip locaInit + $ Vector.tail locaTable' + in GlyfTable + . Vector.generate (Vector.length locaInit) + . generateTable locaInit + . IntMap.fromList + <$> offsets + | otherwise = pure $ GlyfTable mempty + where + filterNullLength (x, y) = x /= y + duplicate x y = fst x == fst y + generateTable :: Vector Word32 -> IntMap GlyphDescription -> Int -> GlyphDescription + generateTable locaInit offsetMap index = + offsetMap IntMap.! fromIntegral (locaInit Vector.! index) + go (locaOffset, nextOffset) = do + startOffset <- Megaparsec.getOffset + result <- glyphDescriptionP + endOffset <- Megaparsec.getOffset + flip Megaparsec.skipCount Megaparsec.Binary.word8 + $ fromIntegral nextOffset + - fromIntegral locaOffset + - endOffset + + startOffset + pure (fromIntegral locaOffset, result) + +-- * Character to glyph mapping table + +cmapTableP :: Parser CmapTable +cmapTableP = do + initialOffset <- Megaparsec.getOffset + version' <- Megaparsec.Binary.word16be + numberSubtables <- fromIntegral <$> Megaparsec.Binary.word16be + encodings' <- sortOn (getField @"offset") + <$> Megaparsec.count numberSubtables cmapHeaderP + parsedSubtables <- Megaparsec.some (subtableAtOffset initialOffset) + Megaparsec.eof + pure $ CmapTable + { version = version' + , encodings = encodings' + , subtables = IntMap.fromList parsedSubtables + } + where + subtableAtOffset initialOffset = do + currentOffset <- flip (-) initialOffset <$> Megaparsec.getOffset + parsedSubtable <- cmapFormatTableP + pure (currentOffset, parsedSubtable) + +cmapHeaderP :: Parser CmapEncoding +cmapHeaderP = CmapEncoding + <$> Megaparsec.Binary.word16be + <*> Megaparsec.Binary.word16be + <*> Megaparsec.Binary.word32be + +cmapFormatTableP :: Parser CmapSubtable +cmapFormatTableP = do + format' <- Megaparsec.Binary.word16be + case format' of + 0 -> CmapFormat0 <$> cmapFormat0TableP + 2 -> CmapFormat2 <$> cmapFormat2TableP + 4 -> CmapFormat4 <$> cmapFormat4TableP + 6 -> CmapFormat6 <$> cmapFormat6TableP + 8 -> CmapFormat8 <$> cmapFormat8TableP + 10 -> CmapFormat10 <$> cmapFormat10TableP + 12 -> CmapFormat12 <$> cmapFormat12TableP + 13 -> CmapFormat13 <$> cmapFormat13TableP + 14 -> CmapFormat14 <$> cmapFormat14TableP + _ -> fail $ "Unsupported format " <> show format' <> "." + +cmapFormat14TableP :: Parser CmapFormat14Table +cmapFormat14TableP = do + initialOffset <- (+ (-2)) <$> Megaparsec.getOffset + Megaparsec.Binary.word32be -- Length. + numVarSelectorRecords <- fromIntegral <$> Megaparsec.Binary.word32be + variationSelectorRecords' <- sortBy sortOffset . fold + <$> Megaparsec.count numVarSelectorRecords variationSelectorRecordP + let parseByOffset' = parseByOffset initialOffset + CmapFormat14Table <$> foldM parseByOffset' IntMap.empty variationSelectorRecords' + where + parseByOffset + :: Int + -> VariationSelectorMap + -> UVSOffset Word32 Word32 + -> Parser VariationSelectorMap + parseByOffset _ accumulator uvsOffset' + | uvsOffset uvsOffset' == 0 = pure accumulator + parseByOffset tableOffset accumulator (DefaultUVSOffset varSelector' relativeOffset) + -- If the records at this offset were already parsed, look at any parsed + -- record and duplicate it updating the varSelector. The same logic + -- applies for the next pattern match, but for non-default UVS. + | Just member@(DefaultUVSOffset _ record :| _) <- + IntMap.lookup (fromIntegral relativeOffset) accumulator = + + let newRecord = DefaultUVSOffset varSelector' record NonEmpty.<| member + relativeOffset' = fromIntegral relativeOffset + in pure $ IntMap.insert relativeOffset' newRecord accumulator + | otherwise = do + currentOffset <- Megaparsec.getOffset + let emptyBytes = tableOffset + fromIntegral relativeOffset - currentOffset + relativeOffset' = fromIntegral relativeOffset + Megaparsec.takeP Nothing emptyBytes + entryCount <- fromIntegral <$> Megaparsec.Binary.word32be + valueRanges <- vectorNP entryCount unicodeValueRangeP + pure $ IntMap.insert relativeOffset' (DefaultUVSOffset varSelector' valueRanges :| []) accumulator + parseByOffset tableOffset accumulator (NonDefaultUVSOffset varSelector' relativeOffset) + | Just member@(NonDefaultUVSOffset _ record :| _) <- + IntMap.lookup (fromIntegral relativeOffset) accumulator = + + let newRecord = NonDefaultUVSOffset varSelector' record NonEmpty.<| member + relativeOffset' = fromIntegral relativeOffset + in pure $ IntMap.insert relativeOffset' newRecord accumulator + | otherwise = do + currentOffset <- Megaparsec.getOffset + let emptyBytes = tableOffset + fromIntegral relativeOffset - currentOffset + Megaparsec.takeP Nothing emptyBytes + entryCount <- fromIntegral <$> Megaparsec.Binary.word32be + flip (IntMap.insert $ fromIntegral relativeOffset) accumulator + . pure + . NonDefaultUVSOffset varSelector' + <$> vectorNP entryCount uvsMappingP + sortOffset x y = compare (uvsOffset x) (uvsOffset y) + +uvsOffset :: forall a. UVSOffset a a -> a +uvsOffset (DefaultUVSOffset _ x) = x +uvsOffset (NonDefaultUVSOffset _ x) = x + +variationSelectorRecordP :: Parser [UVSOffset Word32 Word32] +variationSelectorRecordP = do + varSelector' <- word24P + defaultUVSOffset' <- Megaparsec.Binary.word32be + nonDefaultUVSOffset' <- Megaparsec.Binary.word32be + + pure + [ DefaultUVSOffset varSelector' defaultUVSOffset' + , NonDefaultUVSOffset varSelector' nonDefaultUVSOffset' + ] + +uvsMappingP :: Parser UVSMapping +uvsMappingP = UVSMapping + <$> word24P + <*> Megaparsec.Binary.word16be + +unicodeValueRangeP :: Parser UnicodeValueRange +unicodeValueRangeP = UnicodeValueRange + <$> word24P + <*> Megaparsec.Binary.word8 + +cmapFormat13TableP :: Parser CmapFormat13Table +cmapFormat13TableP = cmapFormat12TableP + +cmapFormat12TableP :: Parser CmapFormat12Table +cmapFormat12TableP = do + Megaparsec.takeP Nothing 6 -- Reserved and length. + language' <- Megaparsec.Binary.word32be + nGroups <- fromIntegral <$> Megaparsec.Binary.word32be + groups' <- vectorNP nGroups cmapGroupP + + pure $ CmapFormat12Table + { language = language' + , groups = groups' + } + +cmapFormat10TableP :: Parser CmapFormat10Table +cmapFormat10TableP = do + Megaparsec.takeP Nothing 2 -- Reserved. + length' <- fromIntegral <$> Megaparsec.Binary.word32be + language' <- Megaparsec.Binary.word32be + startCharCode' <- Megaparsec.Binary.word32be + numChars' <- Megaparsec.Binary.word32be + let remainingLength = div (length' - 24) 2 + glyphs' <- vectorNP remainingLength Megaparsec.Binary.word16be + + pure $ CmapFormat10Table + { language = language' + , startCharCode = startCharCode' + , numChars = numChars' + , glyphs = glyphs' + } + +cmapFormat8TableP :: Parser CmapFormat8Table +cmapFormat8TableP = do + Megaparsec.takeP Nothing 6 -- Reserved and length. + language' <- Megaparsec.Binary.word32be + is32' <- Megaparsec.takeP Nothing 65536 + nGroups <- fromIntegral <$> Megaparsec.Binary.word32be + groups' <- vectorNP nGroups cmapGroupP + + pure $ CmapFormat8Table + { language = language' + , is32 = ByteString.unpack is32' + , groups = groups' + } + +cmapGroupP :: Parser CmapGroup +cmapGroupP = CmapGroup + <$> Megaparsec.Binary.word32be + <*> Megaparsec.Binary.word32be + <*> Megaparsec.Binary.word32be + +cmapFormat6TableP :: Parser CmapFormat6Table +cmapFormat6TableP = do + Megaparsec.Binary.word16be -- Length. + language' <- Megaparsec.Binary.word16be + firstCode' <- Megaparsec.Binary.word16be + entryCount' <- fromIntegral <$> Megaparsec.Binary.word16be + glyphIndexArray' <- vectorNP entryCount' Megaparsec.Binary.word16be + + pure $ CmapFormat6Table + { language = language' + , firstCode = firstCode' + , glyphIndexArray = glyphIndexArray' + } + +cmapFormat4TableP :: Parser CmapFormat4Table +cmapFormat4TableP = do + length' <- fromIntegral <$> Megaparsec.Binary.word16be + language' <- Megaparsec.Binary.word16be + segCount <- fromIntegral . (`div` 2) <$> Megaparsec.Binary.word16be + searchRange' <- Megaparsec.Binary.word16be + entrySelector' <- Megaparsec.Binary.word16be + rangeShift' <- Megaparsec.Binary.word16be + endCode' <- vectorNP segCount Megaparsec.Binary.word16be + rangeShift' <- Megaparsec.Binary.word16be + -- reservedPad 0. + startCode' <- vectorNP segCount Megaparsec.Binary.word16be + idDelta' <- vectorNP segCount Megaparsec.Binary.word16be + idRangeOffset' <- vectorNP segCount Megaparsec.Binary.word16be + let glyphIndexLength = div (length' - 16 - segCount * 8) 2 + glyphIndexArray' <- vectorNP glyphIndexLength Megaparsec.Binary.word16be + + pure $ CmapFormat4Table + { language = language' + , searchRange = searchRange' + , entrySelector = entrySelector' + , rangeShift = rangeShift' + , endCode = endCode' + , startCode = startCode' + , idDelta = idDelta' + , idRangeOffset = idRangeOffset' + , glyphIndexArray = glyphIndexArray' + } + +cmapFormat2TableP :: Parser CmapFormat2Table +cmapFormat2TableP = do + length' <- fromIntegral <$> Megaparsec.Binary.word16be + language' <- Megaparsec.Binary.word16be + subHeaderKeys' <- vectorNP 256 Megaparsec.Binary.word16be + let maxIndex = succ $ fromIntegral $ Vector.maximum $ fmap (`div` 8) subHeaderKeys' + subHeaders' <- vectorNP maxIndex cmapFormat2SubheaderP + let glyphIndexLength = div (length' - 518 - maxIndex * 8) 2 + glyphIndexArray' <- vectorNP glyphIndexLength Megaparsec.Binary.word16be + + pure $ CmapFormat2Table + { language = language' + , subHeaderKeys = subHeaderKeys' + , subHeaders = subHeaders' + , glyphIndexArray = glyphIndexArray' + } + +cmapFormat2SubheaderP :: Parser CmapFormat2Subheader +cmapFormat2SubheaderP = CmapFormat2Subheader + <$> Megaparsec.Binary.word16be + <*> Megaparsec.Binary.word16be + <*> Megaparsec.Binary.int16be + <*> Megaparsec.Binary.word16be + +cmapFormat0TableP :: Parser CmapFormat0Table +cmapFormat0TableP = CmapFormat0Table + <$> Megaparsec.Binary.word16be + <* Megaparsec.Binary.word16be + <*> vectorNP 256 Megaparsec.Binary.word8 + +-- * Generic parsing utilities + +word24P :: Parser Word32 +word24P = foldr unstep 0 . ByteString.unpack + <$> Megaparsec.takeP (Just "word24") 3 + where + unstep b a = a `shiftL` 8 .|. fromIntegral b + +f2Dot14P :: Parser F2Dot14 +f2Dot14P = F2Dot14 <$> Megaparsec.Binary.int16be + +vectorP :: forall a. Parser a -> Parser (Vector a) +vectorP = fmap Vector.fromList . Megaparsec.many + +vectorNP :: forall a. Int -> Parser a -> Parser (Vector a) +vectorNP size = fmap Vector.fromList . Megaparsec.count size + +pascalStringP :: Parser ByteString +pascalStringP = Megaparsec.Binary.word8 + >>= fmap ByteString.pack + . flip Megaparsec.count Megaparsec.Binary.word8 + . fromIntegral + +countP :: forall a. Int -> Parser a -> Parser (NonEmpty a) +countP number parser + = (:|) + <$> parser + <*> Megaparsec.count (number - 1) parser + +longDateTimeP :: Parser LocalTime +longDateTimeP = go <$> Megaparsec.Binary.int64be + where + go totalSeconds = + let (totalDays, secondsOfDay) = totalSeconds `divMod` (3600 * 24) + epoch = fromOrdinalDate 1904 1 + in LocalTime + { localDay = addDays (fromIntegral totalDays) epoch + , localTimeOfDay = timeToTimeOfDay + $ secondsToDiffTime + $ fromIntegral secondsOfDay + } + +fixedP :: Parser Fixed32 +fixedP = Fixed32 . fromIntegral <$> Megaparsec.Binary.word32be + +parseTable + :: TableDirectory + -> Parser a + -> Megaparsec.State ByteString Void + -> Either (Megaparsec.ParseErrorBundle ByteString Void) a +parseTable TableDirectory{ offset, length } parser state = snd + $ Megaparsec.runParser' parser + $ state + { Megaparsec.stateInput = stateInput + , Megaparsec.stateOffset = stateOffset + , Megaparsec.statePosState = posState + { Megaparsec.pstateInput = stateInput + , Megaparsec.pstateOffset = stateOffset + } + } + where + posState = Megaparsec.statePosState state + stateInput = ByteString.take length + $ ByteString.drop (offset - Megaparsec.stateOffset state) + $ Megaparsec.stateInput state + stateOffset = offset + +-- * OS/2 table + +os2TableP :: Parser Os2Table +os2TableP = do + baseFields <- os2BaseFieldsP + result <- case getField @"version" baseFields of + 0 -> Os2Version0 baseFields + <$> Megaparsec.optional os2MicrosoftFieldsP + 1 -> Os2Version1 baseFields + <$> os2MicrosoftFieldsP + <*> os2Version1FieldsP + 2 -> Os2Version2 baseFields + <$> os2MicrosoftFieldsP + <*> os2Version4FieldsP + 3 -> Os2Version3 baseFields + <$> os2MicrosoftFieldsP + <*> os2Version4FieldsP + 4 -> Os2Version4 baseFields + <$> os2MicrosoftFieldsP + <*> os2Version4FieldsP + 5 -> Os2Version5 baseFields + <$> os2MicrosoftFieldsP + <*> os2Version5FieldsP + unsupportedVersion -> fail + $ "Unsupported OS/2 version: " <> show unsupportedVersion + Megaparsec.eof + pure result + +os2BaseFieldsP :: Parser Os2BaseFields +os2BaseFieldsP = Os2BaseFields + <$> Megaparsec.Binary.word16be + <*> Megaparsec.Binary.int16be + <*> Megaparsec.Binary.word16be + <*> Megaparsec.Binary.word16be + <*> Megaparsec.Binary.int16be + <*> Megaparsec.Binary.int16be + <*> Megaparsec.Binary.int16be + <*> Megaparsec.Binary.int16be + <*> Megaparsec.Binary.int16be + <*> Megaparsec.Binary.int16be + <*> Megaparsec.Binary.int16be + <*> Megaparsec.Binary.int16be + <*> Megaparsec.Binary.int16be + <*> Megaparsec.Binary.int16be + <*> Megaparsec.Binary.int16be + <*> Megaparsec.Binary.int16be + <*> panoseP + <*> vectorNP 4 Megaparsec.Binary.word32be + <*> vectorNP 4 Megaparsec.Binary.int8 + <*> Megaparsec.Binary.word16be + <*> Megaparsec.Binary.word16be + <*> Megaparsec.Binary.word16be + +os2MicrosoftFieldsP :: Parser Os2MicrosoftFields +os2MicrosoftFieldsP = Os2MicrosoftFields + <$> Megaparsec.Binary.int16be + <*> Megaparsec.Binary.int16be + <*> Megaparsec.Binary.int16be + <*> Megaparsec.Binary.word16be + <*> Megaparsec.Binary.word16be + +os2Version1FieldsP :: Parser Os2Version1Fields +os2Version1FieldsP = Os2Version1Fields + <$> Megaparsec.Binary.word32be + <*> Megaparsec.Binary.word32be + +os2Version4FieldsP :: Parser Os2Version4Fields +os2Version4FieldsP = Os2Version4Fields + <$> Megaparsec.Binary.word32be + <*> Megaparsec.Binary.word32be + <*> Megaparsec.Binary.int16be + <*> Megaparsec.Binary.int16be + <*> Megaparsec.Binary.word16be + <*> Megaparsec.Binary.word16be + <*> Megaparsec.Binary.word16be + +os2Version5FieldsP :: Parser Os2Version5Fields +os2Version5FieldsP = Os2Version5Fields + <$> Megaparsec.Binary.word32be + <*> Megaparsec.Binary.word32be + <*> Megaparsec.Binary.int16be + <*> Megaparsec.Binary.int16be + <*> Megaparsec.Binary.word16be + <*> Megaparsec.Binary.word16be + <*> Megaparsec.Binary.word16be + <*> Megaparsec.Binary.word16be + <*> Megaparsec.Binary.word16be + +panoseP :: Parser Panose +panoseP = Panose + <$> bFamilyTypeP + <*> bSerifStyleP + <*> bWeightP + <*> bProportionP + <*> bContrastP + <*> bStrokeVariationP + <*> bArmStyleP + <*> bLetterformP + <*> bMidlineP + <*> bXHeightP + +bFamilyTypeP :: Parser BFamilyType +bFamilyTypeP + = (Megaparsec.single 0 $> AnyFamilyType) + <|> (Megaparsec.single 1 $> NoFitFamilyType) + <|> (Megaparsec.single 2 $> TextAndDisplayFamilyType) + <|> (Megaparsec.single 3 $> ScriptFamilyType) + <|> (Megaparsec.single 4 $> DecorativeFamilyType) + <|> (Megaparsec.single 5 $> PictorialFamilyType) + "bFamilyType" + +bSerifStyleP :: Parser BSerifStyle +bSerifStyleP + = (Megaparsec.single 0 $> AnySerifStyle) + <|> (Megaparsec.single 1 $> NoFitSerifStyle) + <|> (Megaparsec.single 2 $> CoveSerifStyle) + <|> (Megaparsec.single 3 $> ObtuseCoveSerifStyle) + <|> (Megaparsec.single 4 $> SquareCoveSerifStyle) + <|> (Megaparsec.single 5 $> ObtuseSquareCoveSerifStyle) + <|> (Megaparsec.single 6 $> SquareSerifStyle) + <|> (Megaparsec.single 7 $> ThinSerifStyle) + <|> (Megaparsec.single 8 $> BoneSerifStyle) + <|> (Megaparsec.single 9 $> ExaggeratedSerifStyle) + <|> (Megaparsec.single 10 $> TriangleSerifStyle) + <|> (Megaparsec.single 11 $> NormalSansSerifStyle) + <|> (Megaparsec.single 12 $> ObtuseSansSerifStyle) + <|> (Megaparsec.single 13 $> PerpSansSerifStyle) + <|> (Megaparsec.single 14 $> FlaredSerifStyle) + <|> (Megaparsec.single 15 $> RoundedSerifStyle) + "bSerifStyle" + +bWeightP :: Parser BWeight +bWeightP + = (Megaparsec.single 0 $> AnyWeight) + <|> (Megaparsec.single 1 $> NoFitWeight) + <|> (Megaparsec.single 2 $> VeryLightWeight) + <|> (Megaparsec.single 3 $> LightWeight) + <|> (Megaparsec.single 4 $> ThinWeight) + <|> (Megaparsec.single 5 $> BookWeight) + <|> (Megaparsec.single 6 $> MediumWeight) + <|> (Megaparsec.single 7 $> DemiWeight) + <|> (Megaparsec.single 8 $> BoldWeight) + <|> (Megaparsec.single 9 $> HeavyWeight) + <|> (Megaparsec.single 10 $> BlackWeight) + <|> (Megaparsec.single 11 $> NordWeight) + "bWeight" + +bProportionP :: Parser BProportion +bProportionP + = (Megaparsec.single 0 $> AnyProportion) + <|> (Megaparsec.single 1 $> NoFitProportion) + <|> (Megaparsec.single 2 $> OldStyleProportion) + <|> (Megaparsec.single 3 $> ModernProportion) + <|> (Megaparsec.single 4 $> EvenWidthProportion) + <|> (Megaparsec.single 5 $> ExpandedProportion) + <|> (Megaparsec.single 6 $> CondensedProportion) + <|> (Megaparsec.single 7 $> VeryExpandedProportion) + <|> (Megaparsec.single 8 $> VeryCondensedProportion) + <|> (Megaparsec.single 9 $> MonospacedProportion) + "bProportion" + +bContrastP :: Parser BContrast +bContrastP + = (Megaparsec.single 0 $> AnyContrast) + <|> (Megaparsec.single 1 $> NoFitContrast) + <|> (Megaparsec.single 2 $> NoneContrast) + <|> (Megaparsec.single 3 $> VeryLowContrast) + <|> (Megaparsec.single 4 $> LowContrast) + <|> (Megaparsec.single 5 $> MediumLowContrast) + <|> (Megaparsec.single 6 $> MediumContrast) + <|> (Megaparsec.single 7 $> MediumHighContrast) + <|> (Megaparsec.single 8 $> HighContrast) + <|> (Megaparsec.single 9 $> VeryHighContrast) + "bContrast" + +bStrokeVariationP :: Parser BStrokeVariation +bStrokeVariationP + = (Megaparsec.single 0 $> AnyStrokeVariatoon) + <|> (Megaparsec.single 1 $> NoFitStrokeVariatoon) + <|> (Megaparsec.single 2 $> GradualDiagonalStrokeVariatoon) + <|> (Megaparsec.single 3 $> GradualTransitionalStrokeVariatoon) + <|> (Megaparsec.single 4 $> GradualVerticalStrokeVariatoon) + <|> (Megaparsec.single 5 $> GradualHorizontalStrokeVariatoon) + <|> (Megaparsec.single 6 $> RapidVerticalStrokeVariatoon) + <|> (Megaparsec.single 7 $> RapidHorizontalStrokeVariatoon) + <|> (Megaparsec.single 8 $> InstantVerticalStrokeVariatoon) + "bStrokeVariation" + +bArmStyleP :: Parser BArmStyle +bArmStyleP + = (Megaparsec.single 0 $> AnyArmStyle) + <|> (Megaparsec.single 1 $> NoFitArmStyle) + <|> (Megaparsec.single 2 $> StraightArmsHorizontalArmStyle) + <|> (Megaparsec.single 3 $> StraightArmsWedgeArmStyle) + <|> (Megaparsec.single 4 $> StraightArmsVerticalArmStyle) + <|> (Megaparsec.single 5 $> StraightArmsSingleSerifArmStyle) + <|> (Megaparsec.single 6 $> StraightArmsDoubleSerifArmStyle) + <|> (Megaparsec.single 7 $> NonStraightArmsHorizontalArmStyle) + <|> (Megaparsec.single 8 $> NonStraightArmsWedgeArmStyle) + <|> (Megaparsec.single 9 $> NonStraightArmsVerticalArmStyle) + <|> (Megaparsec.single 10 $> NonStraightArmsSingleSerifArmStyle) + <|> (Megaparsec.single 11 $> NonStraightArmsDoubleSerifArmStyle) + "bArmStyle" + +bLetterformP :: Parser BLetterform +bLetterformP + = (Megaparsec.single 0 $> AnyLetterform) + <|> (Megaparsec.single 1 $> NoFitLetterform) + <|> (Megaparsec.single 2 $> NormalContactLetterform) + <|> (Megaparsec.single 3 $> NormalWeightedLetterform) + <|> (Megaparsec.single 4 $> NormalBoxedLetterform) + <|> (Megaparsec.single 5 $> NormalFlattenedLetterform) + <|> (Megaparsec.single 6 $> NormalRoundedLetterform) + <|> (Megaparsec.single 7 $> NormalOffCenterLetterform) + <|> (Megaparsec.single 8 $> NormalSquareLetterform) + <|> (Megaparsec.single 9 $> ObliqueContactLetterform) + <|> (Megaparsec.single 10 $> ObliqueWeightedLetterform) + <|> (Megaparsec.single 11 $> ObliqueBoxedLetterform) + <|> (Megaparsec.single 12 $> ObliqueFlattenedLetterform) + <|> (Megaparsec.single 13 $> ObliqueRoundedLetterform) + <|> (Megaparsec.single 14 $> ObliqueOffCenterLetterform) + <|> (Megaparsec.single 15 $> ObliqueSquareLetterform) + "bLetterform" + +bXHeightP :: Parser BXHeight +bXHeightP + = (Megaparsec.single 0 $> AnyXHeight) + <|> (Megaparsec.single 1 $> NoFitXHeight) + <|> (Megaparsec.single 2 $> ConstantSmallXHeight) + <|> (Megaparsec.single 3 $> ConstantStandardXHeight) + <|> (Megaparsec.single 4 $> ConstantLargeXHeight) + <|> (Megaparsec.single 5 $> DuckingSmallXHeight) + <|> (Megaparsec.single 6 $> DuckingStandardXHeight) + <|> (Megaparsec.single 7 $> DuckingLargeXHeight) + "bXHeight" + +bMidlineP :: Parser BMidline +bMidlineP + = (Megaparsec.single 0 $> AnyMidline) + <|> (Megaparsec.single 1 $> NoFitMidline) + <|> (Megaparsec.single 2 $> StandardTrimmedMidline) + <|> (Megaparsec.single 3 $> StandardPointedMidline) + <|> (Megaparsec.single 4 $> StandardSerifedMidline) + <|> (Megaparsec.single 5 $> HighTrimmedMidline) + <|> (Megaparsec.single 6 $> HighPointedMidline) + <|> (Megaparsec.single 7 $> HighSerifedMidline) + <|> (Megaparsec.single 8 $> ConstantTrimmedMidline) + <|> (Megaparsec.single 9 $> ConstantPointedMidline) + <|> (Megaparsec.single 10 $> ConstantSerifedMidline) + <|> (Megaparsec.single 11 $> LowTrimmedMidline) + <|> (Megaparsec.single 12 $> LowPointedMidline) + <|> (Megaparsec.single 13 $> LowSerifedMidline) + "bMidline" diff --git a/src/Graphics/Fountainhead/TrueType.hs b/src/Graphics/Fountainhead/TrueType.hs new file mode 100644 index 0000000..2b70841 --- /dev/null +++ b/src/Graphics/Fountainhead/TrueType.hs @@ -0,0 +1,794 @@ +{-# LANGUAGE DuplicateRecordFields #-} + +-- | Types representing a TrueType font. +module Graphics.Fountainhead.TrueType + ( BArmStyle(..) + , BContrast(..) + , BFamilyType(..) + , BLetterform(..) + , BMidline(..) + , BProportion(..) + , BSerifStyle(..) + , BStrokeVariation(..) + , BWeight(..) + , BXHeight(..) + , CVTable(..) + , CmapSubtable(..) + , CmapTable(..) + , CmapEncoding(..) + , CmapFormat0Table(..) + , CmapFormat2Subheader(..) + , CmapFormat2Table(..) + , CmapFormat4Table(..) + , CmapFormat6Table(..) + , CmapGroup(..) + , CmapFormat8Table(..) + , CmapFormat10Table(..) + , CmapFormat12Table(..) + , CmapFormat13Table + , CmapFormat14Table(..) + , ComponentGlyphFlags(..) + , ComponentGlyphPartDescription(..) + , CompoundGlyphDefinition(..) + , DeviceRecord(..) + , FpgmTable(..) + , FontDirectionHint(..) + , FontDirectory(..) + , FontStyle(..) + , GlyfTable(..) + , GlyphArgument(..) + , GlyphCoordinate(..) + , GlyphDefinition(..) + , GlyphDescription(..) + , GlyphTransformationOption(..) + , HdmxTable(..) + , HeadTable(..) + , HheaTable(..) + , HmtxTable(..) + , LocaTable(..) + , LongHorMetric(..) + , MaxpTable(..) + , NameRecord(..) + , NameTable(..) + , OffsetSubtable(..) + , OpenMaxpTable(..) + , Os2BaseFields(..) + , Os2MicrosoftFields(..) + , Os2Table(..) + , Os2Version1Fields(..) + , Os2Version4Fields(..) + , Os2Version5Fields(..) + , OutlineFlag(..) + , Panose(..) + , PostFormat2Table(..) + , PostHeader(..) + , PostSubtable(..) + , PostTable(..) + , PrepTable(..) + , SimpleGlyphDefinition(..) + , TableDirectory(..) + , TrueMaxpTable(..) + , UVSOffset(..) + , UVSMapping(..) + , UnicodeValueRange(..) + , VariationSelectorMap + , unLocaTable + ) where + +import Data.ByteString (ByteString) +import Data.Int (Int8, Int16) +import Data.IntMap (IntMap) +import Data.List.NonEmpty (NonEmpty(..)) +import Data.Time (LocalTime(..)) +import Data.Vector (Vector) +import Data.Word (Word8, Word16, Word32) +import Graphics.Fountainhead.Type (F2Dot14(..), Fixed32(..)) + +-- * Font directory + +data FontDirectory = FontDirectory + { offsetSubtable :: OffsetSubtable + , tableDirectory :: [TableDirectory] + } deriving (Eq, Show) + +data OffsetSubtable = OffsetSubtable + { scalerType :: Word32 + , numTables :: Int + , searchRange :: Word16 + , entrySelector :: Word16 + , rangeShift :: Word16 + } deriving (Eq, Show) + +data TableDirectory = TableDirectory + { tag :: ByteString + , checkSum :: Word32 + , offset :: Int + , length :: Int + } deriving (Eq, Show) + +-- * Name table + +data NameTable = NameTable + { format :: Word16 -- ^ Format selector. Set to 0. + , nameRecord :: [NameRecord] -- ^ The name records array. + , variable :: [ByteString] -- ^ The character strings of the names. + } deriving (Eq, Show) + +data NameRecord = NameRecord + { platformID :: Word16 -- ^ Platform identifier code. + , platformSpecificID :: Word16 -- ^ Platform-specific encoding identifier. + , languageID :: Word16 -- ^ Language identifier. + , nameID :: Word16 -- ^ Name identifier. + , length :: Int -- ^ Name string length in bytes. + , offset :: Int -- ^ Offset. + } deriving (Eq, Show) + +-- * 'cvt ' table + +newtype CVTable = CVTable [Int16] + deriving (Eq, Show) + +-- * Maximum profile table + +data TrueMaxpTable = TrueMaxpTable + { version :: Fixed32 -- ^ 0x00010000 (1.0). + , numGlyphs :: Word16 -- ^ The number of glyphs in the font. + , maxPoints :: Word16 -- ^ Points in non-compound glyph. + , maxContours :: Word16 -- ^ Contours in non-compound glyph. + , maxComponentPoints :: Word16 -- ^ Points in compound glyph. + , maxComponentContours :: Word16 -- ^ Contours in compound glyph. + , maxZones :: Word16 -- ^ Set to 2. + , maxTwilightPoints :: Word16 -- ^ Points used in Twilight Zone (Z0). + , maxStorage :: Word16 -- ^ Number of Storage Area locations. + , maxFunctionDefs :: Word16 -- ^ Number of FDEFs. + , maxInstructionDefs :: Word16 -- ^ Number of IDEFs. + , maxStackElements :: Word16 -- ^ Maximum stack depth. + , maxSizeOfInstructions :: Word16 -- ^ Byte count for glyph instructions. + , maxComponentElements :: Word16 -- ^ Number of glyphs referenced at top level. + , maxComponentDepth :: Word16 -- ^ Levels of recursion, set to 0 if font has only simple glyphs. + } deriving (Eq, Show) + +data OpenMaxpTable = OpenMaxpTable + { version :: Fixed32 -- ^ 0x00005000 (0.5). + , numGlyphs :: Word16 -- ^ The number of glyphs in the font. + } deriving (Eq, Show) + +data MaxpTable = OpenMaxp OpenMaxpTable | TrueMaxp TrueMaxpTable + deriving (Eq, Show) + +-- * Horizontal header table + +data HheaTable = HheaTable + { version :: Fixed32 -- ^ 0x00010000 (1.0). + , ascent :: Int16 -- ^ Distance from baseline of highest ascender. + , descent :: Int16 -- ^ Distance from baseline of lowest descender. + , lineGap :: Int16 -- ^ Typographic line gap. + , advanceWidthMax :: Word16 -- ^ Must be consistent with horizontal metrics. + , minLeftSideBearing :: Word16 -- ^ Must be consistent with horizontal metrics. + , minRightSideBearing :: Word16 -- ^ Must be consistent with horizontal metrics. + , xMaxExtent :: Word16 -- ^ max(lsb + (xMax-xMin)). + , caretSlopeRise :: Int16 -- ^ used to calculate the slope of the caret (rise/run) set to 1 for vertical caret. + , caretSlopeRun :: Int16 -- ^ 0 for vertical. + , caretOffset :: Int16 -- ^ Set value to 0 for non-slanted fonts. + , metricDataFormat :: Int16 -- ^ 0 for current format. + , numOfLongHorMetrics :: Word16 -- ^ Number of advance widths in metrics table. + } deriving (Eq, Show) + +-- * Font header table + +data HeadTable = HeadTable + { version :: Fixed32 -- ^ 0x00010000 if (version 1.0). + , fontRevision :: Fixed32 -- ^ Set by font manufacturer. + , checkSumAdjustment :: Word32 -- ^ To compute: set it to 0, calculate the checksum for the 'head' table and put it in the table directory, sum the entire font as a uint32_t, then store 0xB1B0AFBA - sum. (The checksum for the 'head' table will be wrong as a result. That is OK; do not reset it.) + , magicNumber :: Word32 -- ^ Set to 0x5F0F3CF5. + , flags :: Word16 + , unitsPerEm :: Word16 -- ^ Range from 64 to 16384. + , created :: LocalTime -- ^ International date. + , modified :: LocalTime -- ^ International date. + , xMin :: Int16 -- ^ For all glyph bounding boxes. + , yMin :: Int16 -- ^ For all glyph bounding boxes. + , xMax :: Int16 -- ^ For all glyph bounding boxes. + , yMax :: Int16 -- ^ For all glyph bounding boxes. + , macStyle :: FontStyle + , lowestRecPPEM :: Word16 -- ^ Smallest readable size in pixels. + , fontDirectionHint :: FontDirectionHint -- ^ 0 Mixed directional glyphs. + , indexToLocFormat :: Word16 -- ^ 0 for short offsets, 1 for long. + , glyphDataFormat :: Word16 -- ^ 0 for current format. + } deriving (Eq, Show) + +data FontStyle = FontStyle + { bold :: Bool + , italic :: Bool + , underline :: Bool + , outline :: Bool + , shadow :: Bool + , condensed :: Bool + , extended :: Bool + } deriving (Eq, Show) + +data FontDirectionHint + = MixedDirectionalGlyphs -- ^ 0. Mixed directional glyphs. + | StronglyLeftToRightGlyphs -- ^ 1. Only strongly left to right glyphs. + | LeftToRightGlyphsWithNeutrals -- ^ 2. Like 1 but also contains neutrals. + | StronglyRightToLeftGlyphs -- ^ -1. Only strongly right to left glyphs. + | RightToLeftGlyphsWithNeutrals -- ^ -2. Like -1 but also contains neutrals. + deriving (Eq, Show) + +data LocaTable + = ShortLocaTable (Vector Word16) + | LongLocaTable (Vector Word32) + deriving (Eq, Show) + +unLocaTable :: LocaTable -> Vector Word32 +unLocaTable (LongLocaTable values) = values +unLocaTable (ShortLocaTable values) = (* 2) . fromIntegral <$> values + +-- * Horizontal metrics table + +data LongHorMetric = LongHorMetric + { advanceWidth :: Word16 + , leftSideBearing :: Int16 + } deriving (Eq, Show) + +data HmtxTable = HmtxTable + { hMetrics :: NonEmpty LongHorMetric + , leftSideBearing :: [Int16] + } deriving (Eq, Show) + +-- * Glyph name and PostScript font table + +data PostHeader = PostHeader + { format :: Fixed32 -- ^ Format of this table + , italicAngle :: Fixed32 -- ^ Italic angle in degrees + , underlinePosition :: Int16 -- ^ Underline position + , underlineThickness :: Int16 -- ^ Underline thickness + , isFixedPitch :: Word32 -- ^ Font is monospaced; set to 1 if the font is monospaced and 0 otherwise (N.B., to maintain compatibility with older versions of the TrueType spec, accept any non-zero value as meaning that the font is monospaced) + , minMemType42 :: Word32 -- ^ Minimum memory usage when a TrueType font is downloaded as a Type 42 font + , maxMemType42 :: Word32 -- ^ Maximum memory usage when a TrueType font is downloaded as a Type 42 font + , minMemType1 :: Word32 -- ^ Minimum memory usage when a TrueType font is downloaded as a Type 1 font + , maxMemType1 :: Word32 -- ^ Maximum memory usage when a TrueType font is downloaded as a Type 1 font + } deriving (Eq, Show) + +data PostFormat2Table = PostFormat2Table + { glyphNameIndex :: Vector Word16 -- ^ Ordinal number of this glyph in 'post' string tables. This is not an offset. + , names :: Vector ByteString + } deriving (Eq, Show) + +data PostSubtable + = None + | PostFormat2 PostFormat2Table + | PostFormat25 (Vector Int8) + | PostFormat4 (Vector Word16) + deriving (Eq, Show) + +data PostTable = PostTable + { postHeader :: PostHeader + , postSubtable :: PostSubtable + } deriving (Eq, Show) + +-- * Font program table + +newtype FpgmTable = FpgmTable (Vector Word8) + deriving (Eq, Show) + +-- * Prep table + +newtype PrepTable = PrepTable (Vector Word8) + deriving (Eq, Show) + +-- * Horizontal device metrics table + +data HdmxTable = HdmxTable + { format :: Int16 -- ^ Format version number. + , records :: [DeviceRecord] + } deriving (Eq, Show) + +data DeviceRecord = DeviceRecord + { pixelSize :: Word8 -- ^ Pixel size for following widths. + , maximumWidth :: Word8 -- ^ Maximum width. + , widths :: Vector Word8 -- ^ Widths. + } deriving (Eq, Show) + +-- * Glyph outline table + +data GlyphDescription = GlyphDescription + { numberOfContours :: Int + , xMin :: Int16 -- ^ Minimum x for coordinate data. + , yMin :: Int16 -- ^ Minimum y for coordinate data. + , xMax :: Int16 -- ^ Maximum x for coordinate data. + , yMax :: Int16 -- ^ Maximum y for coordinate data. + , definition :: GlyphDefinition + } deriving (Eq, Show) + +data GlyphArgument + = GlyphInt16Argument Int16 + | GlyphWord16Argument Word16 + | GlyphInt8Argument Int8 + | GlyphWord8Argument Word8 + deriving (Eq, Show) + +data GlyphTransformationOption + = GlyphNoScale + | GlyphScale F2Dot14 + | GlyphXyScale F2Dot14 F2Dot14 + | Glyph2By2Scale F2Dot14 F2Dot14 F2Dot14 F2Dot14 + deriving (Eq, Show) + +data SimpleGlyphDefinition = SimpleGlyphDefinition + -- | Array of last points of each contour; n is the number of contours; + -- array entries are point indices. + { endPtsOfContours :: Vector Word16 + -- | Array of instructions for this glyph. + , instructions :: Vector Word8 + -- | Array of coordinates; the first is relative to (0,0), others are + -- relative to previous point. + , coordinates :: Vector GlyphCoordinate + } deriving (Eq, Show) + +data CompoundGlyphDefinition = CompoundGlyphDefinition + { components :: Vector ComponentGlyphPartDescription + , instructions :: Vector Word8 + } deriving (Eq, Show) + +data GlyphDefinition + = SimpleGlyph SimpleGlyphDefinition + | CompoundGlyph CompoundGlyphDefinition + deriving (Eq, Show) + +data ComponentGlyphFlags = ComponentGlyphFlags + { roundXyToGrid :: Bool + , weHaveInstructions :: Bool + , useMyMetrics :: Bool + , overlapCompound :: Bool + } deriving (Eq, Show) + +data GlyphCoordinate = GlyphCoordinate + { coordinateX :: Int16 + , coordinateY :: Int16 + , onCurve :: Bool + } deriving (Eq, Show) + +data ComponentGlyphPartDescription = ComponentGlyphPartDescription + { flags :: ComponentGlyphFlags + , glyphIndex :: Word16 + , argument1 :: GlyphArgument + , argument2 :: GlyphArgument + , transformationOption :: GlyphTransformationOption + } deriving (Eq, Show) + +-- * Glyph outline table + +data OutlineFlag = OutlineFlag + { onCurve :: Bool + , xShortVector :: Bool + , yShortVector :: Bool + , thisXIsSame :: Bool + , thisYIsSame :: Bool + } deriving (Eq, Show) + +newtype GlyfTable = GlyfTable (Vector GlyphDescription) + deriving (Eq, Show) + +-- * Character to glyph mapping table + +data CmapTable = CmapTable + { version :: Word16 -- ^ Version number is zero. + -- | Encodings with an offset into subtables map. + , encodings :: [CmapEncoding] + -- ^ The key into the map is the offset in the 'CmapEncoding's. + , subtables :: IntMap CmapSubtable + } deriving (Eq, Show) + +data CmapEncoding = CmapEncoding + { platformID :: Word16 -- ^ Platform identifier + , platformSpecificID :: Word16 -- ^ Platform-specific encoding identifier. + , offset :: Word32 -- ^ Offst of the mapping table. + } deriving (Eq, Show) + +data CmapFormat0Table = CmapFormat0Table + { language :: Word16 -- ^ Language code. + , glyphIndexArray :: Vector Word8 -- ^ An array that maps character codes to glyph index values. + } deriving (Eq, Show) + +data CmapFormat2Subheader = CmapFormat2Subheader + { firstCode :: Word16 + , entryCount :: Word16 + , idDelta :: Int16 + , idRangeOffset :: Word16 + } deriving (Eq, Show) + +data CmapFormat2Table = CmapFormat2Table + { language :: Word16 -- ^ Language code. + , subHeaderKeys :: Vector Word16 -- ^ Array that maps high bytes to subHeaders: value is index * 8. + , subHeaders :: Vector CmapFormat2Subheader -- ^ Variable length array of subHeader structures. + , glyphIndexArray :: Vector Word16 -- ^ Variable length array containing subarrays. + } deriving (Eq, Show) + +data CmapFormat4Table = CmapFormat4Table + { language :: Word16 -- ^ Language code. + , searchRange :: Word16 -- ^ 2 * (2**FLOOR(log2(segCount))). + , entrySelector :: Word16 -- ^ log2(searchRange/2). + , rangeShift :: Word16 -- ^ (2 * segCount) - searchRange. + , endCode :: Vector Word16 -- ^ Ending character code for each segment, last = 0xFFFF. + , startCode :: Vector Word16 -- ^ Starting character code for each segment. + , idDelta :: Vector Word16 -- ^ Delta for all character codes in segment. + , idRangeOffset :: Vector Word16 -- ^ Offset in bytes to glyph indexArray, or 0. + , glyphIndexArray :: Vector Word16 -- ^ Glyph index array. + } deriving (Eq, Show) + +data CmapFormat6Table = CmapFormat6Table + { language :: Word16 -- ^ Language code. + , firstCode :: Word16 -- ^ First character code of subrange. + , glyphIndexArray :: Vector Word16 -- ^ Array of glyph index values for character codes in the range + } deriving (Eq, Show) + +data CmapGroup = CmapGroup + -- | First character code in this group; note that if this group is for one + -- or more 16-bit character codes (which is determined from the is32 array), + -- this 32-bit value will have the high 16-bits set to zero. + { startCharCode :: Word32 + -- | Last character code in this group; same condition as listed above for + -- the startCharCode. + , endCharCode :: Word32 + -- | Glyph index corresponding to the starting character code. + , startGlyphCode :: Word32 + } deriving (Eq, Show) + +data CmapFormat8Table = CmapFormat8Table + { language :: Word32 -- ^ Language code. + -- | Tightly packed array of bits (8K bytes total) indicating whether the + -- particular 16-bit (index) value is the start of a 32-bit character code. + , is32 :: [Word8] + -- | Word32 Number of groupings which follow. + , groups :: Vector CmapGroup + } deriving (Eq, Show) + +data CmapFormat10Table = CmapFormat10Table + { language :: Word32 -- ^ Language code. + , startCharCode :: Word32 -- ^ First character code covered. + , numChars :: Word32 -- ^ Number of character codes covered. + , glyphs :: Vector Word16 -- ^ Array of glyph indices for the character codes covered. + } deriving (Eq, Show) + +data CmapFormat12Table = CmapFormat12Table + { language :: Word32 -- ^ Language code. + , groups :: Vector CmapGroup + } deriving (Eq, Show) + +type CmapFormat13Table = CmapFormat12Table + +newtype CmapFormat14Table = CmapFormat14Table + { varSelectorRecords :: VariationSelectorMap + } deriving (Eq, Show) + +data CmapSubtable + = CmapFormat0 CmapFormat0Table + | CmapFormat2 CmapFormat2Table + | CmapFormat4 CmapFormat4Table + | CmapFormat6 CmapFormat6Table + | CmapFormat8 CmapFormat8Table + | CmapFormat10 CmapFormat10Table + | CmapFormat12 CmapFormat12Table + | CmapFormat13 CmapFormat13Table + | CmapFormat14 CmapFormat14Table + deriving (Eq, Show) + +data UVSOffset a b = DefaultUVSOffset Word32 a | NonDefaultUVSOffset Word32 b + deriving (Eq, Show) + +data UVSMapping = UVSMapping + { unicodeValue :: Word32 -- ^ Base Unicode value of the UVS. + , glyphID :: Word16 -- ^ Glyph ID of the UVS. + } deriving (Eq, Show) + +data UnicodeValueRange = UnicodeValueRange + { startUnicodeValue :: Word32 -- ^ First value in this range. + , additionalCount :: Word8 -- ^ Number of additional values in this range. + } deriving (Eq, Show) + +-- | Mapping from variation selector record offsets to the record data. +type VariationSelectorMap = IntMap + (NonEmpty (UVSOffset (Vector UnicodeValueRange) (Vector UVSMapping))) + +-- * OS/2 table + +data Os2Table + = Os2Version0 Os2BaseFields (Maybe Os2MicrosoftFields) + | Os2Version1 Os2BaseFields Os2MicrosoftFields Os2Version1Fields + | Os2Version2 Os2BaseFields Os2MicrosoftFields Os2Version4Fields + | Os2Version3 Os2BaseFields Os2MicrosoftFields Os2Version4Fields + | Os2Version4 Os2BaseFields Os2MicrosoftFields Os2Version4Fields + | Os2Version5 Os2BaseFields Os2MicrosoftFields Os2Version5Fields + deriving (Eq, Show) + +data Os2Version1Fields = Os2Version1Fields + { ulCodePageRange1 :: Word32 + , ulCodePageRange2 :: Word32 + } deriving (Eq, Show) + +data Os2MicrosoftFields = Os2MicrosoftFields + { sTypoAscender :: Int16 + , sTypoDescender :: Int16 + , sTypoLineGap :: Int16 + , usWinAscent :: Word16 + , usWinDescent :: Word16 + } deriving (Eq, Show) + +data Os2Version4Fields = Os2Version4Fields + { ulCodePageRange1 :: Word32 + , ulCodePageRange2 :: Word32 + , sxHeight :: Int16 + , sCapHeight :: Int16 + , usDefaultChar :: Word16 + , usBreakChar :: Word16 + , usMaxContext :: Word16 + } deriving (Eq, Show) + +data Os2Version5Fields = Os2Version5Fields + { ulCodePageRange1 :: Word32 + , ulCodePageRange2 :: Word32 + , sxHeight :: Int16 + , sCapHeight :: Int16 + , usDefaultChar :: Word16 + , usBreakChar :: Word16 + , usMaxContext :: Word16 + , usLowerOpticalPointSize :: Word16 + , usUpperOpticalPointSize :: Word16 + } deriving (Eq, Show) + +data Os2BaseFields = Os2BaseFields + { version :: Word16 -- ^ Table version number (set to 0). + -- | Average weighted advance width of lower case letters and space. + , xAvgCharWidth :: Int16 + -- | Visual weight (degree of blackness or thickness) of stroke in glyphs. + , usWeightClass :: Word16 + -- | Relative change from the normal aspect ratio (width to height ratio) + -- as specified by a font designer for the glyphs in the font. + , usWidthClass :: Word16 + -- | Characteristics and properties of this font (set undefined bits to + -- zero). + , fsType :: Int16 + -- | Recommended horizontal size in pixels for subscripts. + , ySubscriptXSize :: Int16 + -- | Recommended vertical size in pixels for subscripts. + , ySubscriptYSize :: Int16 + -- | Recommended horizontal offset for subscripts. + , ySubscriptXOffset :: Int16 + -- | Recommended vertical offset form the baseline for subscripts. + , ySubscriptYOffset :: Int16 + -- | Recommended horizontal size in pixels for superscripts. + , ySuperscriptXSize :: Int16 + -- | Recommended vertical size in pixels for superscripts. + , ySuperscriptYSize :: Int16 + -- | Recommended horizontal offset for superscripts. + , ySuperscriptXOffset :: Int16 + -- | Recommended vertical offset from the baseline for superscripts. + , ySuperscriptYOffset :: Int16 + -- | Width of the strikeout stroke. + , yStrikeoutSize :: Int16 + -- | Position of the strikeout stroke relative to the baseline. + , yStrikeoutPosition :: Int16 + -- ^ Classification of font-family design. + , sFamilyClass :: Int16 + -- | 10 byte series of number used to describe the visual characteristics + -- of a given typeface. + , panose :: Panose + -- | Field is split into two bit fields of 96 and 36 bits each. The low 96 + -- bits are used to specify the Unicode blocks encompassed by the font file. + -- The high 32 bits are used to specify the character or script sets covered + -- by the font file. Bit assignments are pending. Set to 0. + , ulUnicodeRange :: Vector Word32 + -- | Four character identifier for the font vendor. + , achVendID :: Vector Int8 + -- | 2-byte bit field containing information concerning the nature of the + -- font patterns. + , fsSelection :: Word16 + -- | The minimum Unicode index in this font. + , fsFirstCharIndex :: Word16 + -- | The maximum Unicode index in this font. + , fsLastCharIndex :: Word16 + } deriving (Eq, Show) + +data Panose = Panose + { bFamilyType :: BFamilyType + , bSerifStyle :: BSerifStyle + , bWeight :: BWeight + , bProportion :: BProportion + , bContrast :: BContrast + , bStrokeVariation :: BStrokeVariation + , bArmStyle :: BArmStyle + , bLetterform :: BLetterform + , bMidline :: BMidline + , bXHeight :: BXHeight + } deriving (Eq, Show) + +data BFamilyType + = AnyFamilyType + | NoFitFamilyType + | TextAndDisplayFamilyType + | ScriptFamilyType + | DecorativeFamilyType + | PictorialFamilyType + deriving (Eq, Show) + +data BSerifStyle + = AnySerifStyle + | NoFitSerifStyle + | CoveSerifStyle + | ObtuseCoveSerifStyle + | SquareCoveSerifStyle + | ObtuseSquareCoveSerifStyle + | SquareSerifStyle + | ThinSerifStyle + | BoneSerifStyle + | ExaggeratedSerifStyle + | TriangleSerifStyle + | NormalSansSerifStyle + | ObtuseSansSerifStyle + | PerpSansSerifStyle + | FlaredSerifStyle + | RoundedSerifStyle + deriving (Eq, Show) + +data BWeight + = AnyWeight + | NoFitWeight + | VeryLightWeight + | LightWeight + | ThinWeight + | BookWeight + | MediumWeight + | DemiWeight + | BoldWeight + | HeavyWeight + | BlackWeight + | NordWeight + deriving (Eq, Show) + +data BProportion + = AnyProportion + | NoFitProportion + | OldStyleProportion + | ModernProportion + | EvenWidthProportion + | ExpandedProportion + | CondensedProportion + | VeryExpandedProportion + | VeryCondensedProportion + | MonospacedProportion + deriving (Eq, Show) + +data BContrast + = AnyContrast + | NoFitContrast + | NoneContrast + | VeryLowContrast + | LowContrast + | MediumLowContrast + | MediumContrast + | MediumHighContrast + | HighContrast + | VeryHighContrast + deriving (Eq, Show) + +data BStrokeVariation + = AnyStrokeVariatoon + | NoFitStrokeVariatoon + | GradualDiagonalStrokeVariatoon + | GradualTransitionalStrokeVariatoon + | GradualVerticalStrokeVariatoon + | GradualHorizontalStrokeVariatoon + | RapidVerticalStrokeVariatoon + | RapidHorizontalStrokeVariatoon + | InstantVerticalStrokeVariatoon + deriving (Eq, Show) + +data BArmStyle + = AnyArmStyle + | NoFitArmStyle + | StraightArmsHorizontalArmStyle + | StraightArmsWedgeArmStyle + | StraightArmsVerticalArmStyle + | StraightArmsSingleSerifArmStyle + | StraightArmsDoubleSerifArmStyle + | NonStraightArmsHorizontalArmStyle + | NonStraightArmsWedgeArmStyle + | NonStraightArmsVerticalArmStyle + | NonStraightArmsSingleSerifArmStyle + | NonStraightArmsDoubleSerifArmStyle + deriving (Eq, Show) + +data BLetterform + = AnyLetterform + | NoFitLetterform + | NormalContactLetterform + | NormalWeightedLetterform + | NormalBoxedLetterform + | NormalFlattenedLetterform + | NormalRoundedLetterform + | NormalOffCenterLetterform + | NormalSquareLetterform + | ObliqueContactLetterform + | ObliqueWeightedLetterform + | ObliqueBoxedLetterform + | ObliqueFlattenedLetterform + | ObliqueRoundedLetterform + | ObliqueOffCenterLetterform + | ObliqueSquareLetterform + deriving (Eq, Show) + +data BMidline + = AnyMidline + | NoFitMidline + | StandardTrimmedMidline + | StandardPointedMidline + | StandardSerifedMidline + | HighTrimmedMidline + | HighPointedMidline + | HighSerifedMidline + | ConstantTrimmedMidline + | ConstantPointedMidline + | ConstantSerifedMidline + | LowTrimmedMidline + | LowPointedMidline + | LowSerifedMidline + deriving (Eq, Show) + +data BXHeight + = AnyXHeight + | NoFitXHeight + | ConstantSmallXHeight + | ConstantStandardXHeight + | ConstantLargeXHeight + | DuckingSmallXHeight + | DuckingStandardXHeight + | DuckingLargeXHeight + deriving (Eq, Show) + +-- * Kern table + +data KernHeader = KernHeader + { version :: Fixed32 -- ^ The version number of the kerning table (0x00010000 for the current version). + } deriving (Eq, Show) + +data KernSubtableHeader = KernSubtableHeader + -- | The length of this subtable in bytes, including this header. + { length :: Word32 + -- | Circumstances under which this table is used. + , coverage :: [Coverage] + -- | The tuple index (used for variations fonts). This value specifies which + -- tuple this subtable covers. + , tupleIndex :: Word16 + } deriving (Eq, Show) + +data Coverage + = KernVertical -- ^ Set if table has vertical kerning values. + | KernCrossStream -- ^ Set if table has cross-stream kerning values. + | KernVariation -- ^ Set if table has variation kerning values. + | KernUnusedBits -- ^ Set to 0. + | KernFormatMask -- ^ Set the format of this subtable (0-3 currently defined). + deriving (Eq, Show) + +data KernFormat0Pair = KernFormat0Pair + { left :: Word16 -- ^ The glyph index for the lefthand glyph in the kerning pair. + , right :: Word16 -- ^ The glyph index for the righthand glyph in the kerning pair. + -- | The kerning value in FUnits for the left and right pair in FUnits. + -- If this value is greater than zero, the glyphs are moved apart. + -- If this value is less than zero, the glyphs are moved together. + , value :: Int16 + } deriving (Eq, Show) + +data KernFormat0Table = KernFormat0Table + { nPairs :: Word16 -- ^ The number of kerning pairs in this subtable. + , searchRange :: Word16 -- ^ The largest power of two less than or equal to the value of nPairs, multiplied by the size in bytes of an entry in the subtable. + -- | This is calculated as log2 of the largest power of two less than or + -- equal to the value of nPairs. This value indicates how many iterations of + -- the search loop have to be made. For example, in a list of eight items, + -- there would be three iterations of the loop. + , entrySelector :: Word16 + -- | The value of nPairs minus the largest power of two less than or equal + -- to nPairs. This is multiplied by the size in bytes of an entry in the + -- table. + , rangeShift :: Word16 + , pairs :: [KernFormat0Pair] + } deriving (Eq, Show) diff --git a/src/Graphics/Fountainhead/Type.hs b/src/Graphics/Fountainhead/Type.hs new file mode 100644 index 0000000..3dc2a3f --- /dev/null +++ b/src/Graphics/Fountainhead/Type.hs @@ -0,0 +1,14 @@ +-- | Generic font types. +module Graphics.Fountainhead.Type + ( F2Dot14(..) + , Fixed32(..) + ) where + +import Data.Int (Int16) +import Data.Word (Word32) + +newtype Fixed32 = Fixed32 Word32 + deriving (Eq, Show) + +newtype F2Dot14 = F2Dot14 Int16 + deriving (Eq, Show)