Dump font style

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
+dumpCaption :: String -> Text.Builder.Builder
-dumpHead headline = Text.Builder.fromString headline
+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 :: ParseErrorOrDump -> TableDirectory -> ParseErrorOrDump
-    go _ (Left accumulator) = Left accumulator
+    go (Left accumulator) _ = Left accumulator
-    go tableEntry (Right 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

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 } =
+    parseVariable variable' NameRecord{ offset, length = length' } =
-        ByteString.take length $ ByteString.drop offset variable'
+        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

src/Graphics/Fountainhead/TrueType.hs

@@ -224,8 +224,8 @@ data LocaTable
     deriving (Eq, Show)
 
 unLocaTable :: LocaTable -> Vector Word32
-unLocaTable (LongLocaTable values) = values
+unLocaTable (LongLocaTable values') = values'
-unLocaTable (ShortLocaTable values) = (* 2) . fromIntegral <$> values
+unLocaTable (ShortLocaTable values') = (* 2) . fromIntegral <$> values'
 
 -- * Horizontal metrics table
 

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