2023-11-11 10:57:43 +01:00
|
|
|
{- 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)
|
2023-11-12 10:13:38 +01:00
|
|
|
import qualified Data.IntMap as IntMap
|
2023-11-11 10:57:43 +01:00
|
|
|
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(..)
|
2023-11-12 10:13:38 +01:00
|
|
|
, TableDirectory(..), CmapEncoding (..)
|
2023-11-11 10:57:43 +01:00
|
|
|
)
|
|
|
|
import qualified Text.Megaparsec as Megaparsec
|
|
|
|
import Graphics.Fountainhead.Parser
|
2023-11-12 10:13:38 +01:00
|
|
|
( fontDirectoryP
|
|
|
|
, parseTable
|
2023-11-11 10:57:43 +01:00
|
|
|
, 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
|
2023-11-12 10:13:38 +01:00
|
|
|
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)
|
2023-11-11 10:57:43 +01:00
|
|
|
|
2023-11-12 10:13:38 +01:00
|
|
|
dumpTables
|
2023-11-11 10:57:43 +01:00
|
|
|
:: Megaparsec.State ByteString Void
|
|
|
|
-> FontDirectory
|
|
|
|
-> ParseErrorOrDump
|
2023-11-12 10:13:38 +01:00
|
|
|
dumpTables processedState directory@FontDirectory{..}
|
2023-11-11 10:57:43 +01:00
|
|
|
= 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
|
2023-11-12 10:13:38 +01:00
|
|
|
|
|
|
|
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
|