Dump cmap encodings

app/Main.hs

@@ -38,29 +38,10 @@ fontMain fontFile = do
     putStrLn $ "Dumping File:" <> fontFile <> "\n\n"
 
     ttfContents <- ByteString.readFile fontFile
-
-    let initialState = Megaparsec.State
-            { stateInput = ttfContents
-            , stateOffset = 0
-            , statePosState = Megaparsec.PosState
-                { pstateInput = ttfContents
-                , pstateOffset = 0
-                , pstateSourcePos = Megaparsec.initialPos fontFile
-                , pstateTabWidth = Megaparsec.defaultTabWidth
-                , pstateLinePrefix = ""
-                }
-            , stateParseErrors = []
-            }
-        (processedState, initialResult) = Megaparsec.runParser' fontDirectoryP initialState 
     
-    case initialResult >>= dumpTrueType processedState of
+    case dumpTrueType ttfContents fontFile of
         (Right fontDump) -> Text.Lazy.putStrLn $ Text.Builder.toLazyText fontDump
         Left e -> putStr (Megaparsec.errorBundlePretty e)
-    {-
-    let Just tableDirectory' = find (("OS/2" ==) . tag) $ tableDirectory directory
-        tableResult = parseTable tableDirectory' os2TableP processedState
-    case tableResult of
-        Right x -> print x -}
 
 main :: IO ()
 main = do

src/Graphics/Fountainhead/Dumper.hs

@@ -17,6 +17,7 @@ module Graphics.Fountainhead.Dumper
 
 import Data.ByteString (ByteString)
 import Data.Int (Int64)
+import qualified Data.IntMap as IntMap
 import qualified Data.Text.Encoding as Text
 import qualified Data.Text.Lazy as Text.Lazy
 import qualified Data.Text.Lazy.Builder as Text.Builder
@@ -27,11 +28,12 @@ import Graphics.Fountainhead.TrueType
     ( CmapTable(..)
     , FontDirectory(..)
     , OffsetSubtable(..)
-    , TableDirectory(..)
+    , TableDirectory(..), CmapEncoding (..)
     )
 import qualified Text.Megaparsec as Megaparsec
 import Graphics.Fountainhead.Parser
-    ( parseTable
+    ( fontDirectoryP
+    , parseTable
     , cmapTableP
     )
 
@@ -83,13 +85,32 @@ dumpOffsetTable directory
         <> newlineBuilder
 
 dumpCmap :: CmapTable -> Text.Builder.Builder
-dumpCmap = const $ dumpHead "'cmap' Table - Character to Glyph Index Mapping Table"
+dumpCmap CmapTable{..}
+    = dumpHead "'cmap' Table - Character to Glyph Index Mapping Table"
+    <> "        'cmap' version: " <> Text.Builder.decimal version <> newlineBuilder
+    <> "        number of encodings: " <> Text.Builder.decimal encodingsLength <> newlineBuilder
+    <> "        number of subtables: " <> Text.Builder.decimal (Prelude.length subtables) <> newlineBuilder
+    <> newlineBuilder
+    <> snd (foldr dumpCmapEncoding (pred encodingsLength, "") encodings) <> newlineBuilder
+  where
+    encodingsLength = Prelude.length encodings
+    dumpCmapEncoding CmapEncoding{..} (index, accumulator) =
+        let findSubTableIndex = Text.Builder.decimal
+                . Prelude.length
+                . filter ((< offset) . fromIntegral)
+                . IntMap.keys
+            summary = "Encoding   " <> Text.Builder.decimal index
+                <> ".    PlatformID:  " <> Text.Builder.decimal platformID <> newlineBuilder
+                <> "                 EcodingID:   " <> Text.Builder.decimal platformSpecificID <> newlineBuilder
+                <> "                 SubTable: " <> findSubTableIndex subtables
+                <> ", Offset: " <> paddedHexadecimal offset <> newlineBuilder
+         in (pred index, summary <> newlineBuilder <> accumulator)
 
-dumpTrueType
+dumpTables
     :: Megaparsec.State ByteString Void
     -> FontDirectory
     -> ParseErrorOrDump
-dumpTrueType processedState directory@FontDirectory{..}
+dumpTables processedState directory@FontDirectory{..}
     = foldr go (Right $ dumpOffsetTable directory) tableDirectory
   where
     go :: TableDirectory -> ParseErrorOrDump -> ParseErrorOrDump
@@ -103,3 +124,21 @@ dumpTrueType processedState directory@FontDirectory{..}
         case getField @"tag" tableEntry of
             "cmap" -> Just $ dumpCmap <$> parseTable tableEntry cmapTableP processedState
             _ -> Nothing
+
+dumpTrueType :: ByteString -> FilePath -> ParseErrorOrDump
+dumpTrueType ttfContents fontFile =
+    let initialState = Megaparsec.State
+            { stateInput = ttfContents
+            , stateOffset = 0
+            , statePosState = Megaparsec.PosState
+                { pstateInput = ttfContents
+                , pstateOffset = 0
+                , pstateSourcePos = Megaparsec.initialPos fontFile
+                , pstateTabWidth = Megaparsec.defaultTabWidth
+                , pstateLinePrefix = ""
+                }
+            , stateParseErrors = []
+            }
+        (processedState, initialResult) = Megaparsec.runParser' fontDirectoryP initialState 
+
+     in initialResult >>= dumpTables processedState