Add font compression

lib/Graphics/Fountainhead.hs

@@ -0,0 +1,49 @@
+{- 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/. -}
+
+-- | Convenience wrappers for working with font files.
+module Graphics.Fountainhead
+    ( dumpFontFile
+    , parseFontDirectoryFromFile
+    ) where
+
+import Data.ByteString (ByteString)
+import Data.Void (Void)
+import Graphics.Fountainhead.Dumper (dumpTables, DumpError(..))
+import Graphics.Fountainhead.Parser (ParseErrorBundle, fontDirectoryP)
+import Graphics.Fountainhead.TrueType (FontDirectory(..))
+import qualified Text.Megaparsec as Megaparsec
+import Text.Megaparsec (PosState(..), State(..))
+import System.IO (IOMode(..), withBinaryFile)
+import Data.Bifunctor (Bifunctor(..))
+import qualified Data.Text.Lazy.Builder as Text.Builder
+import Graphics.Fountainhead.Compression (hDecompress)
+
+parseFontDirectoryFromFile :: FilePath
+    -> IO (State ByteString Void, Either ParseErrorBundle FontDirectory)
+parseFontDirectoryFromFile fontFile =
+    withBinaryFile fontFile ReadMode withFontHandle
+  where
+    withFontHandle fontHandle = doParsing
+        <$> hDecompress fontHandle
+    doParsing ttfContents =
+        let initialState = Megaparsec.State
+                { stateInput = ttfContents
+                , stateOffset = 0
+                , statePosState = Megaparsec.PosState
+                    { pstateInput = ttfContents
+                    , pstateOffset = 0
+                    , pstateSourcePos = Megaparsec.initialPos fontFile
+                    , pstateTabWidth = Megaparsec.defaultTabWidth
+                    , pstateLinePrefix = ""
+                    }
+                , stateParseErrors = []
+                }
+         in Megaparsec.runParser' fontDirectoryP initialState 
+
+dumpFontFile :: FilePath -> IO (Either DumpError Text.Builder.Builder)
+dumpFontFile fontFile = do
+    (processedState, initialResult) <- parseFontDirectoryFromFile fontFile
+
+    pure $ first DumpParseError initialResult >>= dumpTables processedState