From b87abcbf2f6453419952ce38dbef1e906b185767 Mon Sep 17 00:00:00 2001
From: Eugen Wissner <belka@caraus.de>
Date: Tue, 5 Dec 2023 18:36:14 +0100
Subject: [PATCH] Parse GASP table

---
 src/Graphics/Fountainhead/Parser.hs   | 23 +++++++++++++++++--
 src/Graphics/Fountainhead/TrueType.hs | 32 ++++++++++++++++++++++++++-
 2 files changed, 52 insertions(+), 3 deletions(-)

diff --git a/src/Graphics/Fountainhead/Parser.hs b/src/Graphics/Fountainhead/Parser.hs
index 6a5433a..51948f7 100644
--- a/src/Graphics/Fountainhead/Parser.hs
+++ b/src/Graphics/Fountainhead/Parser.hs
@@ -18,6 +18,7 @@ module Graphics.Fountainhead.Parser
     , fixedP
     , fontDirectoryP
     , fpgmTableP
+    , gaspTableP
     , glyfTableP
     , hdmxTableP
     , headTableP
@@ -97,6 +98,8 @@ import Graphics.Fountainhead.TrueType
     , FontDirectionHint(..)
     , FontDirectory(..)
     , FontStyle(..)
+    , GASPRange(..)
+    , GASPTable(..)
     , GlyfTable(..)
     , GlyphArgument(..)
     , GlyphCoordinate(..)
@@ -842,8 +845,7 @@ cmapFormat4TableP = do
     entrySelector' <- Megaparsec.Binary.word16be
     rangeShift' <- Megaparsec.Binary.word16be
     endCode' <- vectorNP segCount Megaparsec.Binary.word16be
-    rangeShift' <- Megaparsec.Binary.word16be
-    -- reservedPad 0.
+    void $ Megaparsec.chunk $ ByteString.pack [0, 0] -- reservedPad 0.
     startCode' <- vectorNP segCount Megaparsec.Binary.word16be
     idDelta' <- vectorNP segCount Megaparsec.Binary.word16be
     idRangeOffset' <- vectorNP segCount Megaparsec.Binary.word16be
@@ -1211,3 +1213,20 @@ bMidlineP
     <|> (Megaparsec.single 12 $> LowPointedMidline)
     <|> (Megaparsec.single 13 $> LowSerifedMidline)
     <?> "bMidline"
+
+-- * Grid-fitting And Scan-conversion Procedure.
+
+gaspTableP :: Parser GASPTable
+gaspTableP = do
+    version' <- Megaparsec.Binary.word16be
+    numberRanges <- fromIntegral <$> Megaparsec.Binary.word16be
+    parsedRanges <- Megaparsec.count numberRanges gaspRangeP
+    Megaparsec.eof
+    pure $ GASPTable
+        { version = version'
+        , gaspRange = parsedRanges
+        }
+  where
+    gaspRangeP = GASPRange
+        <$> Megaparsec.Binary.word16be
+        <*> Megaparsec.Binary.word16be
diff --git a/src/Graphics/Fountainhead/TrueType.hs b/src/Graphics/Fountainhead/TrueType.hs
index 2fff036..3828f38 100644
--- a/src/Graphics/Fountainhead/TrueType.hs
+++ b/src/Graphics/Fountainhead/TrueType.hs
@@ -40,6 +40,8 @@ module Graphics.Fountainhead.TrueType
     , FontDirectionHint(..)
     , FontDirectory(..)
     , FontStyle(..)
+    , GASPRange(..)
+    , GASPTable(..)
     , GlyfTable(..)
     , GlyphArgument(..)
     , GlyphCoordinate(..)
@@ -71,6 +73,7 @@ module Graphics.Fountainhead.TrueType
     , PostSubtable(..)
     , PostTable(..)
     , PrepTable(..)
+    , RangeGaspBehavior(..)
     , SimpleGlyphDefinition(..)
     , TableDirectory(..)
     , TrueMaxpTable(..)
@@ -387,8 +390,9 @@ data OutlineFlag = OutlineFlag
 newtype GlyfTable = GlyfTable (Vector GlyphDescription)
     deriving (Eq, Show)
 
--- * Character to glyph mapping table
+-- 'cmap' table
 
+-- | Character to glyph mapping table.
 data CmapTable = CmapTable
     { version :: Word16 -- ^ Version number is zero.
     -- | Encodings with an offset into subtables map.
@@ -1273,3 +1277,29 @@ data KernFormat2Table = KernFormat2Table
    , classTableHeader :: ClassTableHeader
    , values :: [Int16]
    } deriving (Eq, Show)
+
+-- * 'gasp' table
+
+-- | Grid-fitting And Scan-conversion Procedure.
+data GASPTable = GASPTable
+    { version :: Word16 -- ^ Version number (set to 0).
+    , gaspRange :: [GASPRange] -- ^ Sorted by ppem.
+    } deriving (Eq, Show)
+
+data GASPRange = GASPRange
+    { rangeMaxPPEM :: Word16 -- ^ Upper limit of range, in PPEM.
+    , rangeGaspBehavior :: Word16 -- ^ Flags describing desired rasterizer behavior.
+    } deriving (Eq, Show)
+
+data RangeGaspBehavior
+    = KGASPGridFit -- ^ Use gridfitting.
+    | KGASPDoGray -- ^ Use grayscale rendering.
+    deriving (Eq, Show)
+
+instance Enum RangeGaspBehavior
+  where
+    toEnum 1 = KGASPGridFit
+    toEnum 2 = KGASPDoGray
+    toEnum _ = error "Unknown range GASP behavior"
+    fromEnum KGASPGridFit = 1
+    fromEnum KGASPDoGray = 2