Move ttf dumper to a module

3 files changed, 108 insertions, 2 deletions

diff --git a/src/Graphics/Fountainhead/Dumper.hs b/src/Graphics/Fountainhead/Dumper.hs
new file mode 100644
index 0000000..379dcb0
--- /dev/null
+++ b/src/Graphics/Fountainhead/Dumper.hs
@@ -0,0 +1,105 @@
+{- This Source Code Form is subject to the terms of the Mozilla Public License,
+   v. 2.0. If a copy of the MPL was not distributed with this file, You can
+   obtain one at https://mozilla.org/MPL/2.0/. -}
+
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE RecordWildCards #-}
+
+-- | Outputs information about a font as text.
+module Graphics.Fountainhead.Dumper
+    ( ParseErrorOrDump
+    , dumpCmap
+    , dumpTrueType
+    , dumpOffsetTable
+    ) where
+
+import Data.ByteString (ByteString)
+import Data.Int (Int64)
+import qualified Data.Text.Encoding as Text
+import qualified Data.Text.Lazy as Text.Lazy
+import qualified Data.Text.Lazy.Builder as Text.Builder
+import qualified Data.Text.Lazy.Builder.Int as Text.Builder
+import Data.Void
+import GHC.Records (HasField(..))
+import Graphics.Fountainhead.TrueType
+    ( CmapTable(..)
+    , FontDirectory(..)
+    , OffsetSubtable(..)
+    , TableDirectory(..)
+    )
+import qualified Text.Megaparsec as Megaparsec
+import Graphics.Fountainhead.Parser
+    ( parseTable
+    , cmapTableP
+    )
+
+type ParseErrorOrDump
+    = Either (Megaparsec.ParseErrorBundle ByteString Void) Text.Builder.Builder
+
+paddedHexadecimal :: Integral a => a -> Text.Builder.Builder
+paddedHexadecimal = ("0x" <>)
+    . Text.Builder.fromLazyText
+    . Text.Lazy.justifyRight 8 '0'
+    . Text.Builder.toLazyText
+    . Text.Builder.hexadecimal
+
+justifyNumber :: Integral a => Int64 -> a -> Text.Builder.Builder
+justifyNumber count = Text.Builder.fromLazyText
+    . Text.Lazy.justifyRight count ' '
+    . Text.Builder.toLazyText
+    . Text.Builder.decimal
+
+newlineBuilder :: Text.Builder.Builder
+newlineBuilder = Text.Builder.singleton '\n'
+
+dumpHead :: String -> Text.Builder.Builder
+dumpHead headline = Text.Builder.fromString headline
+    <> newlineBuilder
+    <> Text.Builder.fromLazyText (Text.Lazy.replicate headlineLength "-")
+    <> newlineBuilder
+  where
+    headlineLength = fromIntegral $ Prelude.length headline
+
+dumpOffsetTable :: FontDirectory -> Text.Builder.Builder
+dumpOffsetTable directory
+    = dumpHead "Offset Table"
+    <> "         sfnt version:           1.0\n         number of tables: "
+    <> Text.Builder.decimal (numTables $ offsetSubtable directory)
+    <> newlineBuilder
+    <> dumpOffsetSummary (tableDirectory directory)
+  where
+    dumpOffsetSummary = mconcat . fmap dumpOffsetRow . zip [0..]
+    dumpOffsetRow (index, table) = justifyNumber 4 index
+        <> ". '"
+        <> Text.Builder.fromText (Text.decodeASCII $ tag table)
+        <> "' - checksum = "
+        <> paddedHexadecimal (getField @"checkSum" table)
+        <> ", offset = "
+        <> paddedHexadecimal (getField @"offset" table)
+        <> ", len = "
+        <> justifyNumber 9 (getField @"length" table)
+        <> newlineBuilder
+
+dumpCmap :: CmapTable -> Text.Builder.Builder
+dumpCmap = const $ dumpHead "'cmap' Table - Character to Glyph Index Mapping Table"
+
+dumpTrueType
+    :: Megaparsec.State ByteString Void
+    -> FontDirectory
+    -> ParseErrorOrDump
+dumpTrueType processedState directory@FontDirectory{..}
+    = foldr go (Right $ dumpOffsetTable directory) tableDirectory
+  where
+    go :: TableDirectory -> ParseErrorOrDump -> ParseErrorOrDump
+    go tableEntry (Left accumulator) = Left accumulator
+    go tableEntry (Right accumulator)
+        = maybe (Right accumulator) (concatDump accumulator)
+        $ dumpSubTable tableEntry
+    concatDump accumulator builderDump = ((accumulator <> newlineBuilder) <>)
+        <$> builderDump
+    dumpSubTable tableEntry =
+        case getField @"tag" tableEntry of
+            "cmap" -> Just $ dumpCmap <$> parseTable tableEntry cmapTableP processedState
+            _ -> Nothing
diff --git a/src/Graphics/Fountainhead/Parser.hs b/src/Graphics/Fountainhead/Parser.hs
index 6d2b900..ea809d2 100644
--- a/src/Graphics/Fountainhead/Parser.hs
+++ b/src/Graphics/Fountainhead/Parser.hs
@@ -11,7 +11,8 @@
 
 -- | Font parser.
 module Graphics.Fountainhead.Parser
-    ( cmapTableP
+    ( Parser
+    , cmapTableP
     , cvTableP
     , f2Dot14P
     , fixedP
diff --git a/src/Graphics/Fountainhead/TrueType.hs b/src/Graphics/Fountainhead/TrueType.hs
index a461d52..5b6eb68 100644
--- a/src/Graphics/Fountainhead/TrueType.hs
+++ b/src/Graphics/Fountainhead/TrueType.hs
@@ -751,7 +751,7 @@ data BXHeight
 
 -- * Kern table
 
-data KernHeader = KernHeader
+newtype KernHeader = KernHeader
     { version :: Fixed32 -- ^ The version number of the kerning table (0x00010000 for the current version).
     } deriving (Eq, Show)