Dump hmtx

1 files changed, 52 insertions, 17 deletions

diff --git a/src/Graphics/Fountainhead/Dumper.hs b/src/Graphics/Fountainhead/Dumper.hs
index e5bf6e7..91659ee 100644
--- a/src/Graphics/Fountainhead/Dumper.hs
+++ b/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