summaryrefslogtreecommitdiff
path: root/src/Graphics
diff options
context:
space:
mode:
Diffstat (limited to 'src/Graphics')
-rw-r--r--src/Graphics/Fountainhead/Dumper.hs61
-rw-r--r--src/Graphics/Fountainhead/Parser.hs14
-rw-r--r--src/Graphics/Fountainhead/TrueType.hs4
-rw-r--r--src/Graphics/Fountainhead/Type.hs6
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
generated by cgit v1.2.3 (git 2.26.2) at 2026-06-26 21:49:52 +0000