Decompress defalte compressed fonts

1 files changed, 50 insertions, 0 deletions

diff --git a/src/Graphics/Fountainhead.hs b/src/Graphics/Fountainhead.hs
new file mode 100644
index 0000000..f965680
--- /dev/null
+++ b/src/Graphics/Fountainhead.hs
@@ -0,0 +1,50 @@
+{- 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/. -}
+
+module Graphics.Fountainhead
+    ( parseFontDirectoryFromFile
+    ) where
+
+import qualified Codec.Compression.Zlib as Zlib
+import Data.ByteString (ByteString)
+import qualified Data.ByteString as ByteString
+import qualified Data.ByteString.Lazy as ByteString.Lazy
+import Data.Void (Void)
+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(..), SeekMode(..), hFileSize, hSeek, withBinaryFile)
+
+parseFontDirectoryFromFile :: String
+    -> IO (State ByteString Void, Either ParseErrorBundle FontDirectory)
+parseFontDirectoryFromFile fontFile =
+    withBinaryFile fontFile ReadMode withFontHandle
+  where
+    withFontHandle fontHandle = doParsing
+        <$> readFontContents 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 
+    readFontContents fontHandle = do
+        firstBytes <- ByteString.unpack <$> ByteString.hGet fontHandle 2
+        hSeek fontHandle AbsoluteSeek 0
+        fileSize <- fromIntegral <$> hFileSize fontHandle
+        case firstBytes of
+            0x78 : [secondByte]
+                | secondByte `elem` [0x01, 0x9c, 0x5e, 0xda] ->
+                    ByteString.Lazy.toStrict . Zlib.decompress
+                        <$> ByteString.Lazy.hGet fontHandle fileSize
+            _ -> ByteString.hGetContents fontHandle