50 lines
2.1 KiB
Haskell
50 lines
2.1 KiB
Haskell
{- 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 (dumpTable, 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 -> Maybe String -> IO (Either DumpError Text.Builder.Builder)
|
|
dumpFontFile fontFile tableName = do
|
|
let dumpRequest = maybe dumpTables dumpTable tableName
|
|
(processedState, initialResult) <- parseFontDirectoryFromFile fontFile
|
|
pure $ first DumpParseError initialResult >>= dumpRequest processedState
|