From ac03d3236deececd13660295d8528e2d0de639ed Mon Sep 17 00:00:00 2001 From: Eugen Wissner Date: Thu, 16 Nov 2023 09:09:59 +0100 Subject: [PATCH] Dump font style --- src/Graphics/Fountainhead/Dumper.hs | 61 +++++++++++++++++++++++---- src/Graphics/Fountainhead/Parser.hs | 14 +++--- src/Graphics/Fountainhead/TrueType.hs | 4 +- src/Graphics/Fountainhead/Type.hs | 6 +++ 4 files changed, 66 insertions(+), 19 deletions(-) diff --git a/src/Graphics/Fountainhead/Dumper.hs b/src/Graphics/Fountainhead/Dumper.hs index e7c6156..f09469d 100644 --- a/src/Graphics/Fountainhead/Dumper.hs +++ b/src/Graphics/Fountainhead/Dumper.hs @@ -12,6 +12,7 @@ module Graphics.Fountainhead.Dumper ( ParseErrorOrDump , dumpCmap + , dumpHead , dumpTrueType , dumpOffsetTable ) where @@ -31,20 +32,26 @@ import GHC.Records (HasField(..)) import Graphics.Fountainhead.TrueType ( CmapTable(..) , FontDirectory(..) + , HeadTable(..) , OffsetSubtable(..) , TableDirectory(..) , CmapEncoding(..) , CmapSubtable(..) , CmapFormat4Table(..) + , FontStyle(..) ) import qualified Text.Megaparsec as Megaparsec import Graphics.Fountainhead.Parser ( fontDirectoryP , parseTable , cmapTableP + , headTableP ) +import Graphics.Fountainhead.Type (ttfEpoch) import Data.Foldable (Foldable(..)) import Data.Maybe (fromMaybe) +import Data.Time (LocalTime(..), NominalDiffTime, diffLocalTime, midnight) +import Data.Bits (Bits(setBit)) type ParseErrorOrDump = Either (Megaparsec.ParseErrorBundle ByteString Void) Text.Builder.Builder @@ -71,8 +78,8 @@ justifyNumber count = Text.Builder.fromLazyText newlineBuilder :: Text.Builder.Builder newlineBuilder = Text.Builder.singleton '\n' -dumpHead :: String -> Text.Builder.Builder -dumpHead headline = Text.Builder.fromString headline +dumpCaption :: String -> Text.Builder.Builder +dumpCaption headline = Text.Builder.fromString headline <> newlineBuilder <> Text.Builder.fromLazyText (Text.Lazy.replicate headlineLength "-") <> newlineBuilder @@ -81,7 +88,7 @@ dumpHead headline = Text.Builder.fromString headline dumpOffsetTable :: FontDirectory -> Text.Builder.Builder dumpOffsetTable directory - = dumpHead "Offset Table" + = dumpCaption "Offset Table" <> " sfnt version: 1.0\n number of tables: " <> Text.Builder.decimal (numTables $ offsetSubtable directory) <> newlineBuilder @@ -99,9 +106,46 @@ dumpOffsetTable directory <> justifyNumber 9 (getField @"length" table) <> newlineBuilder +dumpHead :: HeadTable -> Text.Builder.Builder +dumpHead HeadTable{..} + = dumpCaption "'head' Table - Font Header" + {- version + <> lowestRecPPEM + <> indexToLocFormat + <> glyphDataFormat + <> fontRevision + <> fontDirectionHint -} + <> " checkSumAdjustment: " <> paddedHexadecimal checkSumAdjustment <> newlineBuilder + <> " magicNumber: " <> paddedHexadecimal magicNumber <> newlineBuilder + <> " flags: 0x" <> halfPaddedHexadecimal flags <> newlineBuilder + <> " unitsPerEm: " <> Text.Builder.decimal unitsPerEm <> newlineBuilder + <> " created: " <> "0x" <> longDateTime created <> newlineBuilder + <> " modified: " <> "0x" <> longDateTime modified <> newlineBuilder + <> " xMin: " <> Text.Builder.decimal xMin <> newlineBuilder + <> " yMin: " <> Text.Builder.decimal yMin <> newlineBuilder + <> " xMax: " <> Text.Builder.decimal xMax <> newlineBuilder + <> " yMax: " <> Text.Builder.decimal yMax <> newlineBuilder + <> " macStyle bits: " <> "0x" <> dumpFontStyle macStyle <> newlineBuilder + +dumpFontStyle :: FontStyle -> Text.Builder.Builder +dumpFontStyle FontStyle{..} = halfPaddedHexadecimal + $ foldr (go . fst) (0 :: Int) + $ filter snd + $ zip [0..] [bold, italic, underline, outline, shadow, condensed, extended] + where + go bitNumber accumulator = setBit accumulator bitNumber + +longDateTime :: LocalTime -> Text.Builder.Builder +longDateTime localTime = Text.Builder.fromLazyText + $ Text.Lazy.justifyRight 16 '0' + $ Text.Builder.toLazyText + $ Text.Builder.hexadecimal + $ (truncate :: NominalDiffTime -> Int) + $ diffLocalTime localTime (LocalTime ttfEpoch midnight) + dumpCmap :: CmapTable -> Text.Builder.Builder dumpCmap CmapTable{..} - = dumpHead "'cmap' Table - Character to Glyph Index Mapping Table" + = dumpCaption "'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 @@ -200,11 +244,11 @@ dumpTables -> FontDirectory -> ParseErrorOrDump dumpTables processedState directory@FontDirectory{..} - = foldr go (Right $ dumpOffsetTable directory) tableDirectory + = foldl' go (Right $ dumpOffsetTable directory) tableDirectory where - go :: TableDirectory -> ParseErrorOrDump -> ParseErrorOrDump - go _ (Left accumulator) = Left accumulator - go tableEntry (Right accumulator) + go :: ParseErrorOrDump -> TableDirectory -> ParseErrorOrDump + go (Left accumulator) _ = Left accumulator + go (Right accumulator) tableEntry = maybe (Right accumulator) (concatDump accumulator) $ dumpSubTable tableEntry concatDump accumulator builderDump = ((accumulator <> newlineBuilder) <>) @@ -212,6 +256,7 @@ dumpTables processedState directory@FontDirectory{..} dumpSubTable tableEntry = case getField @"tag" tableEntry of "cmap" -> Just $ dumpCmap <$> parseTable tableEntry cmapTableP processedState + "head" -> Just $ dumpHead <$> parseTable tableEntry headTableP processedState _ -> Nothing dumpTrueType :: ByteString -> FilePath -> ParseErrorOrDump diff --git a/src/Graphics/Fountainhead/Parser.hs b/src/Graphics/Fountainhead/Parser.hs index ea809d2..02d7a29 100644 --- a/src/Graphics/Fountainhead/Parser.hs +++ b/src/Graphics/Fountainhead/Parser.hs @@ -49,18 +49,15 @@ import Data.Int (Int8, Int16) import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap import Data.Functor (($>)) -import Data.List (nub, sort, sortOn, nubBy, sortBy) +import Data.List (sortOn, nubBy, sortBy) import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NonEmpty -import Data.Maybe (fromMaybe) import Data.Time ( LocalTime(..) - , TimeOfDay(..) , addDays , secondsToDiffTime , timeToTimeOfDay ) -import Data.Time.Calendar.OrdinalDate (fromOrdinalDate) import Data.Vector (Vector) import qualified Data.Vector as Vector import Data.Void (Void) @@ -139,7 +136,7 @@ import Graphics.Fountainhead.TrueType , VariationSelectorMap , unLocaTable ) -import Graphics.Fountainhead.Type (F2Dot14(..), Fixed32(..)) +import Graphics.Fountainhead.Type (F2Dot14(..), Fixed32(..), ttfEpoch) import Text.Megaparsec (()) import qualified Text.Megaparsec as Megaparsec import qualified Text.Megaparsec.Byte.Binary as Megaparsec.Binary @@ -196,8 +193,8 @@ nameTableP = do , variable = parseVariable variable' <$> nameRecord' } where - parseVariable variable' NameRecord{ offset, length } = - ByteString.take length $ ByteString.drop offset variable' + parseVariable variable' NameRecord{ offset, length = length' } = + ByteString.take length' $ ByteString.drop offset variable' nameRecordP :: Parser NameRecord nameRecordP = NameRecord @@ -915,9 +912,8 @@ longDateTimeP = go <$> Megaparsec.Binary.int64be where go totalSeconds = let (totalDays, secondsOfDay) = totalSeconds `divMod` (3600 * 24) - epoch = fromOrdinalDate 1904 1 in LocalTime - { localDay = addDays (fromIntegral totalDays) epoch + { localDay = addDays (fromIntegral totalDays) ttfEpoch , localTimeOfDay = timeToTimeOfDay $ secondsToDiffTime $ fromIntegral secondsOfDay diff --git a/src/Graphics/Fountainhead/TrueType.hs b/src/Graphics/Fountainhead/TrueType.hs index 5b6eb68..16c95b1 100644 --- a/src/Graphics/Fountainhead/TrueType.hs +++ b/src/Graphics/Fountainhead/TrueType.hs @@ -224,8 +224,8 @@ data LocaTable deriving (Eq, Show) unLocaTable :: LocaTable -> Vector Word32 -unLocaTable (LongLocaTable values) = values -unLocaTable (ShortLocaTable values) = (* 2) . fromIntegral <$> values +unLocaTable (LongLocaTable values') = values' +unLocaTable (ShortLocaTable values') = (* 2) . fromIntegral <$> values' -- * Horizontal metrics table diff --git a/src/Graphics/Fountainhead/Type.hs b/src/Graphics/Fountainhead/Type.hs index 2493157..118df6b 100644 --- a/src/Graphics/Fountainhead/Type.hs +++ b/src/Graphics/Fountainhead/Type.hs @@ -6,13 +6,19 @@ module Graphics.Fountainhead.Type ( F2Dot14(..) , Fixed32(..) + , ttfEpoch ) where import Data.Int (Int16) import Data.Word (Word32) +import Data.Time (Day(..)) +import Data.Time.Calendar.OrdinalDate (fromOrdinalDate) newtype Fixed32 = Fixed32 Word32 deriving (Eq, Show) newtype F2Dot14 = F2Dot14 Int16 deriving (Eq, Show) + +ttfEpoch :: Day +ttfEpoch = fromOrdinalDate 1904 1