Move ttf dumper to a module

5 files changed, 122 insertions, 44 deletions

diff --git a/app/Main.hs b/app/Main.hs
index aee0fd4..89a8dcd 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -15,6 +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)
 -- TODO: kern table since format 1.
 -- For details on subtable format see examples in TrueType reference.
 import Graphics.Fountainhead.Parser
@@ -50,49 +51,17 @@ fontMain fontFile = do
                 }
             , stateParseErrors = []
             }
-        (processedState, Right directory) = Megaparsec.runParser' fontDirectoryP initialState
-
-    Text.Lazy.putStrLn $ Text.Builder.toLazyText $ dumpOffsetTable directory
-    {- print directory
+        (processedState, initialResult) = Megaparsec.runParser' fontDirectoryP initialState 
+    
+    case initialResult >>= dumpTrueType processedState 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
-        Left e -> putStr (Megaparsec.errorBundlePretty e)
         Right x -> print x -}
 
-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
-
-dumpOffsetTable :: FontDirectory -> Text.Builder.Builder
-dumpOffsetTable directory
-    = "Offset Table\n------------\n"
-    <> "         sfnt version:           1.0\n         number of tables: "
-    <> Text.Builder.decimal (numTables $ offsetSubtable directory)
-    <> Text.Builder.singleton '\n'
-    <> 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)
-        <> Text.Builder.singleton '\n'
-
 main :: IO ()
 main = do
     programArguments <- getArgs
diff --git a/fountainhead.cabal b/fountainhead.cabal
index ce06a61..2e1427c 100644
--- a/fountainhead.cabal
+++ b/fountainhead.cabal
@@ -19,8 +19,14 @@ extra-source-files:
   CHANGELOG.md
   README.txt
 
+common dependencies
+  build-depends:
+    text ^>= 2.0
+
 library
+  import: dependencies
   exposed-modules:
+    Graphics.Fountainhead.Dumper
     Graphics.Fountainhead.Parser
     Graphics.Fountainhead.PDF
     Graphics.Fountainhead.Type
@@ -37,15 +43,13 @@ library
     vector ^>= 0.13.0
 
 executable fountainhead
+  import: dependencies
   main-is: Main.hs
 
   default-extensions:
-    OverloadedStrings
     NamedFieldPuns
-    DataKinds
     DuplicateRecordFields
     ExplicitForAll
-    TypeApplications
   build-depends:
     base,
     bytestring,
@@ -53,7 +57,6 @@ executable fountainhead
     parser-combinators,
     vector,
     transformers,
-    text,
     time,
     megaparsec,
     fountainhead
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)