Dump the loca table

src/Graphics/Fountainhead/Dumper.hs

@@ -3,7 +3,6 @@
    obtain one at https://mozilla.org/MPL/2.0/. -}
 
 {-# LANGUAGE DataKinds #-}
-{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE RecordWildCards #-}
@@ -15,6 +14,8 @@ module Graphics.Fountainhead.Dumper
     , dumpCmap
     , dumpHead
     , dumpHmtx
+    , dumpHhea
+    , dumpLoca
     , dumpTrueType
     , dumpOffsetTable
     ) where
@@ -22,7 +23,7 @@ module Graphics.Fountainhead.Dumper
 import Data.ByteString (ByteString)
 import qualified Data.ByteString.Char8 as Char8
 import Data.Int (Int64)
-import Data.Word (Word16)
+import Data.Word (Word16, Word32)
 import qualified Data.IntMap as IntMap
 import qualified Data.Text.Encoding as Text
 import qualified Data.Text.Lazy as Text.Lazy
@@ -46,6 +47,8 @@ import Graphics.Fountainhead.TrueType
     , CmapFormat4Table(..)
     , FontStyle(..)
     , LongHorMetric(..)
+    , LocaTable(..)
+    , IndexToLocFormat(..)
     )
 import qualified Text.Megaparsec as Megaparsec
 import Graphics.Fountainhead.Parser
@@ -55,6 +58,7 @@ import Graphics.Fountainhead.Parser
     , headTableP
     , hheaTableP
     , hmtxTableP
+    , locaTableP
     )
 import Graphics.Fountainhead.Type (Fixed32(..), ttfEpoch)
 import Data.Foldable (Foldable(..), find)
@@ -67,6 +71,11 @@ data DumpError
     = DumpParseError (Megaparsec.ParseErrorBundle ByteString Void)
     | DumpRequiredTableMissingError String
 
+data RequiredTables = RequiredTables
+    { hheaTable :: HheaTable
+    , headTable :: HeadTable
+    } deriving (Eq, Show)
+
 paddedHexadecimal :: Integral a => a -> Text.Builder.Builder
 paddedHexadecimal = ("0x" <>)
     . Text.Builder.fromLazyText
@@ -180,9 +189,13 @@ dumpHead HeadTable{..}
     <> "         macStyle bits:          " <> "0x" <> dumpFontStyle macStyle <> newlineBuilder
     <> "         lowestRecPPEM           " <> Text.Builder.decimal lowestRecPPEM <> newlineBuilder
     <> "         fontDirectionHint       " <> dumpFontDirectionHint fontDirectionHint <> newlineBuilder
-    <> "         indexToLocFormat        " <> Text.Builder.decimal indexToLocFormat <> newlineBuilder
+    <> "         indexToLocFormat        " <> dumpIndexToLocFormat indexToLocFormat <> newlineBuilder
     <> "         glyphDataFormat         " <> Text.Builder.decimal glyphDataFormat <> newlineBuilder
 
+dumpIndexToLocFormat :: IndexToLocFormat -> Text.Builder.Builder
+dumpIndexToLocFormat ShortOffsetIndexToLocFormat = "0"
+dumpIndexToLocFormat LongOffsetIndexToLocFormat = "1"
+
 dumpFontDirectionHint :: FontDirectionHint -> Text.Builder.Builder
 dumpFontDirectionHint = \case
     MixedDirectionalGlyphs -> "0"
@@ -303,34 +316,60 @@ dumpCmap CmapTable{..}
     dumpGlyphAtIndex index element = "                 glyphIdArray[" <> Text.Builder.decimal index <> "] =  "
         <> Text.Builder.decimal element <> newlineBuilder
 
+dumpLoca :: LocaTable -> Text.Builder.Builder
+dumpLoca table =
+    dumpCaption "'loca' Table - Index to Location"
+    <> go table
+  where
+    go (LongLocaTable elements) = dumpElements elements
+    go (ShortLocaTable elements) = dumpElements
+        $ (* 2)
+        . (fromIntegral :: Word16 -> Word32)
+        <$> elements
+    dumpElements elements =
+        case Vector.unsnoc elements of
+            Just (init', last')
+                -> foldMap dumpLocaLine (Vector.indexed init')
+                <> "         Ended at " <> paddedHexadecimal last'
+            Nothing -> mempty
+    dumpLocaLine :: Integral a => (Int, a) -> Text.Builder.Builder
+    dumpLocaLine (index, element)
+        = "         Idx " <> justifyNumber 6 index
+        <> " -> GlyphOffset " <> paddedHexadecimal element <> newlineBuilder
+
 dumpTables
     :: Megaparsec.State ByteString Void
     -> FontDirectory
     -> Either DumpError Text.Builder.Builder
-dumpTables processedState directory@FontDirectory{..} =
-    findRequired "hhea" hheaTableP >>= traverseDirectory
+dumpTables processedState directory@FontDirectory{..}
+    = parseRequired >>= traverseDirectory
   where
-    traverseDirectory parsedHhea =
+    traverseDirectory parsedRequired =
         let initial = Right $ dumpOffsetTable directory
-         in foldl' (go parsedHhea) initial tableDirectory
+         in foldl' (go parsedRequired) initial tableDirectory
+    parseRequired = RequiredTables
+        <$> findRequired "hhea" hheaTableP
+        <*> findRequired "head" headTableP
     findRequired tableName parser = 
         let missingError = Left $ DumpRequiredTableMissingError tableName
-            parseRequired tableEntry = parseTable tableEntry parser processedState
-         in maybe missingError (first DumpParseError . parseRequired)
+            parseFound tableEntry = parseTable tableEntry parser processedState
+         in maybe missingError (first DumpParseError . parseFound)
             $ find ((== Char8.pack tableName) . getField @"tag") tableDirectory
     go _ (Left accumulator) _ = Left accumulator
-    go hheaTable (Right accumulator) tableEntry
+    go parsedRequired (Right accumulator) tableEntry
         = maybe (Right accumulator) (concatDump accumulator . first DumpParseError)
-        $ dumpSubTable hheaTable tableEntry
+        $ dumpSubTable parsedRequired tableEntry
     concatDump accumulator builderDump = ((accumulator <> newlineBuilder) <>)
         <$> builderDump
-    dumpSubTable hheaTable@HheaTable{ numOfLongHorMetrics } tableEntry =
+    dumpSubTable RequiredTables{..} tableEntry =
         case getField @"tag" tableEntry of
             "cmap" -> Just $ dumpCmap <$> parseTable tableEntry cmapTableP processedState
-            "head" -> Just $ dumpHead <$> parseTable tableEntry headTableP processedState
+            "head" -> Just $ Right $ dumpHead headTable
             "hhea" -> Just $ Right $ dumpHhea hheaTable
             "hmtx" -> Just $ dumpHmtx
-                <$> parseTable tableEntry (hmtxTableP numOfLongHorMetrics) processedState
+                <$> parseTable tableEntry (hmtxTableP $ getField @"numOfLongHorMetrics" hheaTable) processedState
+            "loca" -> Just $ dumpLoca
+                <$> parseTable tableEntry (locaTableP $ getField @"indexToLocFormat" headTable) processedState
             _ -> Nothing
 
 dumpTrueType :: ByteString -> FilePath -> Either DumpError Text.Builder.Builder

src/Graphics/Fountainhead/Parser.hs

@@ -23,6 +23,7 @@ module Graphics.Fountainhead.Parser
     , headTableP
     , hheaTableP
     , hmtxTableP
+    , locaTableP
     , longDateTimeP
     , longLocaTableP
     , maxpTableP
@@ -107,6 +108,7 @@ import Graphics.Fountainhead.TrueType
     , HeadTable(..)
     , HheaTable(..)
     , HmtxTable(..)
+    , IndexToLocFormat(..)
     , LocaTable(..)
     , LongHorMetric(..)
     , MaxpTable(..)
@@ -293,9 +295,17 @@ headTableP = HeadTable
     <*> fontStyleP
     <*> Megaparsec.Binary.word16be
     <*> fontDirectionHintP
-    <*> Megaparsec.Binary.word16be
+    <*> indexToLocFormatP
     <*> Megaparsec.Binary.word16be
     <* Megaparsec.eof
+  where
+    indexToLocFormatP = do
+        indexToLocFormat' <- Megaparsec.Binary.int16be
+        case indexToLocFormat' of
+            0 -> pure ShortOffsetIndexToLocFormat
+            1 -> pure LongOffsetIndexToLocFormat
+            _ -> fail $ "Unknown loca table format indexToLocFormat: "
+                <> show indexToLocFormat'
 
 fontStyleP :: Parser FontStyle
 fontStyleP = go <$> Megaparsec.Binary.word16be
@@ -330,6 +340,10 @@ shortLocaTableP = ShortLocaTable
     <$> vectorP Megaparsec.Binary.word16be
     <?> "loca table, short version"
 
+locaTableP :: IndexToLocFormat -> Parser LocaTable
+locaTableP ShortOffsetIndexToLocFormat = shortLocaTableP
+locaTableP LongOffsetIndexToLocFormat = longLocaTableP
+
 -- * Horizontal metrics table
 
 longHorMetricP :: Parser LongHorMetric
@@ -587,9 +601,8 @@ simpleGlyphDefinitionP numberOfContours' = do
                     , thisXIsSame = testBit flag 4
                     , thisYIsSame = testBit flag 5
                     }
-                repeat = testBit flag 3
             repeatN <- 
-                if repeat
+                if testBit flag 3
                 then (1 +)
                     . fromIntegral
                     <$> Megaparsec.Binary.word8

src/Graphics/Fountainhead/TrueType.hs

@@ -49,6 +49,7 @@ module Graphics.Fountainhead.TrueType
     , HeadTable(..)
     , HheaTable(..)
     , HmtxTable(..)
+    , IndexToLocFormat(..)
     , LocaTable(..)
     , LongHorMetric(..)
     , MaxpTable(..)
@@ -180,6 +181,11 @@ data HheaTable = HheaTable
 
 -- * Font header table
 
+data IndexToLocFormat
+    = ShortOffsetIndexToLocFormat
+    | LongOffsetIndexToLocFormat
+    deriving (Eq, Show)
+
 data HeadTable = HeadTable
     { version :: Fixed32 -- ^ 0x00010000 if (version 1.0).
     , fontRevision :: Fixed32 -- ^ Set by font manufacturer.
@@ -196,7 +202,7 @@ data HeadTable = HeadTable
     , macStyle :: FontStyle
     , lowestRecPPEM :: Word16 -- ^ Smallest readable size in pixels.
     , fontDirectionHint :: FontDirectionHint -- ^ 0 Mixed directional glyphs.
-    , indexToLocFormat :: Word16 -- ^ 0 for short offsets, 1 for long.
+    , indexToLocFormat :: IndexToLocFormat -- ^ 0 for short offsets, 1 for long.
     , glyphDataFormat :: Word16 -- ^ 0 for current format.
     } deriving (Eq, Show)