Dump the name table

2 files changed, 62 insertions, 3 deletions

diff --git a/src/Graphics/Fountainhead/Dumper.hs b/src/Graphics/Fountainhead/Dumper.hs
index cea7c9a..dc23b4a 100644
--- a/src/Graphics/Fountainhead/Dumper.hs
+++ b/src/Graphics/Fountainhead/Dumper.hs
@@ -4,9 +4,10 @@
 
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE PatternGuards #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE TypeApplications #-}
 
 -- | Outputs information about a font as text.
 module Graphics.Fountainhead.Dumper
@@ -16,16 +17,19 @@ module Graphics.Fountainhead.Dumper
     , dumpHmtx
     , dumpHhea
     , dumpLoca
+    , dumpName
     , dumpMaxp
     , dumpTrueType
     , dumpOffsetTable
     ) where
 
 import Data.ByteString (ByteString)
+import qualified Data.ByteString as ByteString
 import qualified Data.ByteString.Char8 as Char8
 import Data.Int (Int64)
-import Data.Word (Word16, Word32)
+import Data.Word (Word8, Word16, Word32)
 import qualified Data.IntMap as IntMap
+import qualified Data.Text as Text
 import qualified Data.Text.Encoding as Text
 import qualified Data.Text.Lazy as Text.Lazy
 import qualified Data.Text.Lazy.Builder as Text.Builder
@@ -49,10 +53,13 @@ import Graphics.Fountainhead.TrueType
     , FontStyle(..)
     , LongHorMetric(..)
     , LocaTable(..)
+    , NameRecord (..)
+    , NameTable(..)
     , IndexToLocFormat(..)
     , OpenMaxpTable(..)
     , MaxpTable(..)
     , TrueMaxpTable(..)
+    , nameStringOffset
     )
 import qualified Text.Megaparsec as Megaparsec
 import Graphics.Fountainhead.Parser
@@ -63,7 +70,7 @@ import Graphics.Fountainhead.Parser
     , hheaTableP
     , hmtxTableP
     , locaTableP
-    , maxpTableP
+    , maxpTableP, nameTableP
     )
 import Graphics.Fountainhead.Type (Fixed32(..), ttfEpoch)
 import Data.Foldable (Foldable(..), find)
@@ -71,6 +78,7 @@ import Data.Maybe (fromMaybe)
 import Data.Time (LocalTime(..), NominalDiffTime, diffLocalTime, midnight)
 import Data.Bits (Bits(..))
 import Data.Bifunctor (Bifunctor(first))
+import Data.List (intersperse)
 
 data DumpError
     = DumpParseError (Megaparsec.ParseErrorBundle ByteString Void)
@@ -342,6 +350,48 @@ dumpLoca table =
         = "         Idx " <> justifyNumber 6 index
         <> " -> GlyphOffset " <> paddedHexadecimal element <> newlineBuilder
 
+dumpName :: NameTable -> Text.Builder.Builder
+dumpName table'@NameTable{..} = dumpCaption "'name' Table - Naming Table"
+    <> "         Format:                 " <> Text.Builder.decimal format <> newlineBuilder
+    <> "         Number of Record:       " <> Text.Builder.decimal (Prelude.length nameRecord) <> newlineBuilder
+    <> "         Storage offset:         " <> Text.Builder.decimal (nameStringOffset table') <> newlineBuilder
+    <> foldMap go (zip3 [0 :: Int ..] nameRecord variable)
+  where
+    go (index, NameRecord{ length = length', ..}, variable')
+        = "Name table " <> justifyNumber 3 index <> "."
+        <> "  PlatformID:     " <> Text.Builder.decimal platformID <> newlineBuilder
+        <> "                 EncodingID:     " <> Text.Builder.decimal platformSpecificID <> newlineBuilder
+        <> "                 LanguageID:     " <> Text.Builder.decimal languageID <> newlineBuilder
+        <> "                 NameID:         " <> Text.Builder.decimal nameID <> newlineBuilder
+        <> "                 Length:         " <> Text.Builder.decimal length' <> newlineBuilder
+        <> "                 Offset:         " <> Text.Builder.decimal offset <> newlineBuilder
+        <> foldMap ("                 " <>) (dumpHexString $ ByteString.unpack variable')
+
+dumpHexString :: [Word8] -> [Text.Builder.Builder]
+dumpHexString byteCodes
+    | null byteCodes = [dumpHexLine " > " byteCodes]
+    | Prelude.length byteCodes < 10 = [dumpHexLine "  > " byteCodes]
+    | otherwise = dumpHexLine "  >  " byteCodes
+        : dumpHexString (drop 10 byteCodes)
+  where
+    dumpHexLine separator variable' =
+        let firstTen = take 10 variable'
+            digits = fold $ intersperse (Text.Builder.singleton ' ') $ hexByte <$> firstTen
+            printables = foldMap printableByte firstTen
+         in digits
+            <> Text.Builder.fromText (Text.replicate (10 - Prelude.length firstTen) "   ")
+            <> separator
+            <> printables
+            <> newlineBuilder
+    hexByte = Text.Builder.fromLazyText
+        . Text.Lazy.justifyRight 2 '0'
+        . Text.Builder.toLazyText . Text.Builder.hexadecimal
+    printableByte :: Word8 -> Text.Builder.Builder
+    printableByte code
+        | code >= 0x20
+        , code < 0x7f = Text.Builder.singleton $ toEnum $ fromIntegral code
+        | otherwise = Text.Builder.singleton '.'
+
 dumpMaxp :: MaxpTable -> Text.Builder.Builder
 dumpMaxp (TrueMaxp TrueMaxpTable{..})
     = dumpCaption "'maxp' Table - Maximum Profile"
@@ -399,6 +449,7 @@ dumpTables processedState directory@FontDirectory{..}
             "loca" -> Just $ dumpLoca
                 <$> parseTable tableEntry (locaTableP $ getField @"indexToLocFormat" headTable) processedState
             "maxp" -> Just $ dumpMaxp <$> parseTable tableEntry maxpTableP processedState
+            "name" -> Just $ dumpName <$> parseTable tableEntry nameTableP processedState
             _ -> Nothing
 
 dumpTrueType :: ByteString -> FilePath -> Either DumpError Text.Builder.Builder
diff --git a/src/Graphics/Fountainhead/TrueType.hs b/src/Graphics/Fountainhead/TrueType.hs
index 4043098..5de0918 100644
--- a/src/Graphics/Fountainhead/TrueType.hs
+++ b/src/Graphics/Fountainhead/TrueType.hs
@@ -3,6 +3,7 @@
    obtain one at https://mozilla.org/MPL/2.0/. -}
 
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE RecordWildCards #-}
 
 -- | Types representing a TrueType font.
 module Graphics.Fountainhead.TrueType
@@ -78,6 +79,7 @@ module Graphics.Fountainhead.TrueType
     , UnicodeValueRange(..)
     , VariationSelectorMap
     , unLocaTable
+    , nameStringOffset
     ) where
 
 import Data.ByteString (ByteString)
@@ -128,6 +130,12 @@ data NameRecord = NameRecord
     , offset :: Int -- ^ Offset.
     } deriving (Eq, Show)
 
+nameStringOffset :: NameTable -> Word16
+nameStringOffset NameTable{..} =
+    let nameRecordSize = 12
+        precedingFieldsSize = 2 * 3
+     in nameRecordSize * fromIntegral (Prelude.length nameRecord) + precedingFieldsSize
+
 -- * 'cvt ' table
 
 newtype CVTable = CVTable [Int16]