Dump hmtx

app/Main.hs

@@ -15,7 +15,7 @@ import qualified Data.Text.Lazy as Text.Lazy
 import qualified Data.Text.Lazy.IO as Text.Lazy
 import qualified Data.Text.Encoding as Text
 import GHC.Records (HasField(..))
-import Graphics.Fountainhead.Dumper (dumpTrueType)
+import Graphics.Fountainhead.Dumper (DumpError(..), dumpTrueType)
 -- TODO: kern table since format 1.
 -- For details on subtable format see examples in TrueType reference.
 import Graphics.Fountainhead.Parser
@@ -40,8 +40,12 @@ fontMain fontFile = do
     ttfContents <- ByteString.readFile fontFile
     
     case dumpTrueType ttfContents fontFile of
-        (Right fontDump) -> Text.Lazy.putStrLn $ Text.Builder.toLazyText fontDump
-        Left e -> putStr (Megaparsec.errorBundlePretty e)
+        Right fontDump -> Text.Lazy.putStrLn $ Text.Builder.toLazyText fontDump
+        Left e
+            | DumpParseError bundle <- e -> putStr
+                $ Megaparsec.errorBundlePretty bundle
+            | DumpRequiredTableMissingError tableName <- e -> putStr
+                $ "Required table " <> tableName <> " is missing."
 
 main :: IO ()
 main = do

src/Graphics/Fountainhead/Dumper.hs

@@ -3,6 +3,7 @@
    obtain one at https://mozilla.org/MPL/2.0/. -}
 
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE RecordWildCards #-}
@@ -10,14 +11,16 @@
 
 -- | Outputs information about a font as text.
 module Graphics.Fountainhead.Dumper
-    ( ParseErrorOrDump
+    ( DumpError(..)
     , dumpCmap
     , dumpHead
+    , dumpHmtx
     , dumpTrueType
     , dumpOffsetTable
     ) where
 
 import Data.ByteString (ByteString)
+import qualified Data.ByteString.Char8 as Char8
 import Data.Int (Int64)
 import Data.Word (Word16)
 import qualified Data.IntMap as IntMap
@@ -35,12 +38,14 @@ import Graphics.Fountainhead.TrueType
     , FontDirectionHint(..)
     , HeadTable(..)
     , HheaTable(..)
+    , HmtxTable(..)
     , OffsetSubtable(..)
     , TableDirectory(..)
     , CmapEncoding(..)
     , CmapSubtable(..)
     , CmapFormat4Table(..)
     , FontStyle(..)
+    , LongHorMetric(..)
     )
 import qualified Text.Megaparsec as Megaparsec
 import Graphics.Fountainhead.Parser
@@ -49,15 +54,18 @@ import Graphics.Fountainhead.Parser
     , cmapTableP
     , headTableP
     , hheaTableP
+    , hmtxTableP
     )
 import Graphics.Fountainhead.Type (Fixed32(..), ttfEpoch)
-import Data.Foldable (Foldable(..))
+import Data.Foldable (Foldable(..), find)
 import Data.Maybe (fromMaybe)
 import Data.Time (LocalTime(..), NominalDiffTime, diffLocalTime, midnight)
 import Data.Bits (Bits(..))
+import Data.Bifunctor (Bifunctor(first))
 
-type ParseErrorOrDump
-    = Either (Megaparsec.ParseErrorBundle ByteString Void) Text.Builder.Builder
+data DumpError
+    = DumpParseError (Megaparsec.ParseErrorBundle ByteString Void)
+    | DumpRequiredTableMissingError String
 
 paddedHexadecimal :: Integral a => a -> Text.Builder.Builder
 paddedHexadecimal = ("0x" <>)
@@ -115,9 +123,27 @@ dumpFixed32 (Fixed32 word)
     <> Text.Builder.singleton '.'
     <> Text.Builder.decimal (word .&. 0xff00)
 
+dumpHmtx :: HmtxTable -> Text.Builder.Builder
+dumpHmtx HmtxTable{..} =
+    let caption = dumpCaption "'hmtx' Table - Horizontal Metrics"
+        lastAccumulator = foldl' dumpHMetric (0 :: Int, caption) hMetrics
+     in snd $ foldl' dumpLeftSideBear lastAccumulator leftSideBearing
+  where
+    dumpLeftSideBear (index, accumulator) leftSideBearing' =
+        let withNewLine = dumpIndex index <> ". LSbear: "
+                <> justifyNumber 4 leftSideBearing' <> newlineBuilder
+         in (succ index, accumulator <> withNewLine)
+    dumpHMetric (index, accumulator) metric =
+        let LongHorMetric{ leftSideBearing = leftSideBearing', ..} = metric
+            withNewLine = dumpIndex index <> ". advWid: "
+                <> justifyNumber 4 advanceWidth <> ",  LSBear: "
+                <> justifyNumber 4 leftSideBearing' <> newlineBuilder
+         in (succ index, accumulator <> withNewLine)
+    dumpIndex = justifyNumber 12
+
 dumpHhea :: HheaTable -> Text.Builder.Builder
 dumpHhea HheaTable{..}
-    = dumpCaption "'hhea' Table - Font Header"
+    = dumpCaption "'hhea' Table - Horizontal Header"
     <> "         'hhea' version:         " <> dumpFixed32 version <> newlineBuilder
     <> "         yAscender:              " <> Text.Builder.decimal ascent <> newlineBuilder
     <> "         yDescender:             " <> Text.Builder.decimal descent <> newlineBuilder
@@ -280,25 +306,34 @@ dumpCmap CmapTable{..}
 dumpTables
     :: Megaparsec.State ByteString Void
     -> FontDirectory
-    -> ParseErrorOrDump
-dumpTables processedState directory@FontDirectory{..}
-    = foldl' go (Right $ dumpOffsetTable directory) tableDirectory
+    -> Either DumpError Text.Builder.Builder
+dumpTables processedState directory@FontDirectory{..} =
+    findRequired "hhea" hheaTableP >>= traverseDirectory
   where
-    go :: ParseErrorOrDump -> TableDirectory -> ParseErrorOrDump
-    go (Left accumulator) _ = Left accumulator
-    go (Right accumulator) tableEntry
-        = maybe (Right accumulator) (concatDump accumulator)
-        $ dumpSubTable tableEntry
+    traverseDirectory parsedHhea =
+        let initial = Right $ dumpOffsetTable directory
+         in foldl' (go parsedHhea) initial tableDirectory
+    findRequired tableName parser = 
+        let missingError = Left $ DumpRequiredTableMissingError tableName
+            parseRequired tableEntry = parseTable tableEntry parser processedState
+         in maybe missingError (first DumpParseError . parseRequired)
+            $ find ((== Char8.pack tableName) . getField @"tag") tableDirectory
+    go _ (Left accumulator) _ = Left accumulator
+    go hheaTable (Right accumulator) tableEntry
+        = maybe (Right accumulator) (concatDump accumulator . first DumpParseError)
+        $ dumpSubTable hheaTable tableEntry
     concatDump accumulator builderDump = ((accumulator <> newlineBuilder) <>)
         <$> builderDump
-    dumpSubTable tableEntry =
+    dumpSubTable hheaTable@HheaTable{ numOfLongHorMetrics } tableEntry =
         case getField @"tag" tableEntry of
             "cmap" -> Just $ dumpCmap <$> parseTable tableEntry cmapTableP processedState
             "head" -> Just $ dumpHead <$> parseTable tableEntry headTableP processedState
-            "hhea" -> Just $ dumpHhea <$> parseTable tableEntry hheaTableP processedState
+            "hhea" -> Just $ Right $ dumpHhea hheaTable
+            "hmtx" -> Just $ dumpHmtx
+                <$> parseTable tableEntry (hmtxTableP numOfLongHorMetrics) processedState
             _ -> Nothing
 
-dumpTrueType :: ByteString -> FilePath -> ParseErrorOrDump
+dumpTrueType :: ByteString -> FilePath -> Either DumpError Text.Builder.Builder
 dumpTrueType ttfContents fontFile =
     let initialState = Megaparsec.State
             { stateInput = ttfContents
@@ -314,4 +349,4 @@ dumpTrueType ttfContents fontFile =
             }
         (processedState, initialResult) = Megaparsec.runParser' fontDirectoryP initialState 
 
-     in initialResult >>= dumpTables processedState
+     in first DumpParseError initialResult >>= dumpTables processedState

src/Graphics/Fountainhead/Parser.hs

@@ -337,9 +337,9 @@ longHorMetricP = LongHorMetric
     <$> Megaparsec.Binary.word16be
     <*> Megaparsec.Binary.int16be
 
-hmtxTableP :: Int -> Parser HmtxTable
+hmtxTableP :: Word16 -> Parser HmtxTable
 hmtxTableP numOfLongHorMetrics = HmtxTable
-    <$> countP numOfLongHorMetrics longHorMetricP
+    <$> countP (fromIntegral numOfLongHorMetrics) longHorMetricP
     <*> Megaparsec.many Megaparsec.Binary.int16be
 
 -- * Glyph name and PostScript font table
@@ -928,7 +928,7 @@ parseTable
     -> Parser a
     -> Megaparsec.State ByteString Void
     -> Either (Megaparsec.ParseErrorBundle ByteString Void) a
-parseTable TableDirectory{ offset, length } parser state = snd
+parseTable TableDirectory{ offset, length = length' } parser state = snd
     $ Megaparsec.runParser' parser 
     $ state
         { Megaparsec.stateInput = stateInput
@@ -940,7 +940,7 @@ parseTable TableDirectory{ offset, length } parser state = snd
         }
   where
     posState = Megaparsec.statePosState state
-    stateInput = ByteString.take length
+    stateInput = ByteString.take length'
         $ ByteString.drop (offset - Megaparsec.stateOffset state)
         $ Megaparsec.stateInput state
     stateOffset = offset