diff --git a/app/Main.hs b/app/Main.hs index c2c9787..23a86b9 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -15,7 +15,7 @@ import qualified Data.Text.Lazy as Text.Lazy import qualified Data.Text.Lazy.IO as Text.Lazy import qualified Data.Text.Encoding as Text import GHC.Records (HasField(..)) -import Graphics.Fountainhead.Dumper (dumpTrueType) +import Graphics.Fountainhead.Dumper (DumpError(..), dumpTrueType) -- TODO: kern table since format 1. -- For details on subtable format see examples in TrueType reference. import Graphics.Fountainhead.Parser @@ -40,8 +40,12 @@ fontMain fontFile = do ttfContents <- ByteString.readFile fontFile case dumpTrueType ttfContents fontFile of - (Right fontDump) -> Text.Lazy.putStrLn $ Text.Builder.toLazyText fontDump - Left e -> putStr (Megaparsec.errorBundlePretty e) + Right fontDump -> Text.Lazy.putStrLn $ Text.Builder.toLazyText fontDump + Left e + | DumpParseError bundle <- e -> putStr + $ Megaparsec.errorBundlePretty bundle + | DumpRequiredTableMissingError tableName <- e -> putStr + $ "Required table " <> tableName <> " is missing." main :: IO () main = do diff --git a/src/Graphics/Fountainhead/Dumper.hs b/src/Graphics/Fountainhead/Dumper.hs index e5bf6e7..91659ee 100644 --- a/src/Graphics/Fountainhead/Dumper.hs +++ b/src/Graphics/Fountainhead/Dumper.hs @@ -3,6 +3,7 @@ obtain one at https://mozilla.org/MPL/2.0/. -} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE RecordWildCards #-} @@ -10,14 +11,16 @@ -- | Outputs information about a font as text. module Graphics.Fountainhead.Dumper - ( ParseErrorOrDump + ( DumpError(..) , dumpCmap , dumpHead + , dumpHmtx , dumpTrueType , dumpOffsetTable ) where import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as Char8 import Data.Int (Int64) import Data.Word (Word16) import qualified Data.IntMap as IntMap @@ -35,12 +38,14 @@ import Graphics.Fountainhead.TrueType , FontDirectionHint(..) , HeadTable(..) , HheaTable(..) + , HmtxTable(..) , OffsetSubtable(..) , TableDirectory(..) , CmapEncoding(..) , CmapSubtable(..) , CmapFormat4Table(..) , FontStyle(..) + , LongHorMetric(..) ) import qualified Text.Megaparsec as Megaparsec import Graphics.Fountainhead.Parser @@ -49,15 +54,18 @@ import Graphics.Fountainhead.Parser , cmapTableP , headTableP , hheaTableP + , hmtxTableP ) import Graphics.Fountainhead.Type (Fixed32(..), ttfEpoch) -import Data.Foldable (Foldable(..)) +import Data.Foldable (Foldable(..), find) import Data.Maybe (fromMaybe) import Data.Time (LocalTime(..), NominalDiffTime, diffLocalTime, midnight) import Data.Bits (Bits(..)) +import Data.Bifunctor (Bifunctor(first)) -type ParseErrorOrDump - = Either (Megaparsec.ParseErrorBundle ByteString Void) Text.Builder.Builder +data DumpError + = DumpParseError (Megaparsec.ParseErrorBundle ByteString Void) + | DumpRequiredTableMissingError String paddedHexadecimal :: Integral a => a -> Text.Builder.Builder paddedHexadecimal = ("0x" <>) @@ -115,9 +123,27 @@ dumpFixed32 (Fixed32 word) <> Text.Builder.singleton '.' <> Text.Builder.decimal (word .&. 0xff00) +dumpHmtx :: HmtxTable -> Text.Builder.Builder +dumpHmtx HmtxTable{..} = + let caption = dumpCaption "'hmtx' Table - Horizontal Metrics" + lastAccumulator = foldl' dumpHMetric (0 :: Int, caption) hMetrics + in snd $ foldl' dumpLeftSideBear lastAccumulator leftSideBearing + where + dumpLeftSideBear (index, accumulator) leftSideBearing' = + let withNewLine = dumpIndex index <> ". LSbear: " + <> justifyNumber 4 leftSideBearing' <> newlineBuilder + in (succ index, accumulator <> withNewLine) + dumpHMetric (index, accumulator) metric = + let LongHorMetric{ leftSideBearing = leftSideBearing', ..} = metric + withNewLine = dumpIndex index <> ". advWid: " + <> justifyNumber 4 advanceWidth <> ", LSBear: " + <> justifyNumber 4 leftSideBearing' <> newlineBuilder + in (succ index, accumulator <> withNewLine) + dumpIndex = justifyNumber 12 + dumpHhea :: HheaTable -> Text.Builder.Builder dumpHhea HheaTable{..} - = dumpCaption "'hhea' Table - Font Header" + = dumpCaption "'hhea' Table - Horizontal Header" <> " 'hhea' version: " <> dumpFixed32 version <> newlineBuilder <> " yAscender: " <> Text.Builder.decimal ascent <> newlineBuilder <> " yDescender: " <> Text.Builder.decimal descent <> newlineBuilder @@ -280,25 +306,34 @@ dumpCmap CmapTable{..} dumpTables :: Megaparsec.State ByteString Void -> FontDirectory - -> ParseErrorOrDump -dumpTables processedState directory@FontDirectory{..} - = foldl' go (Right $ dumpOffsetTable directory) tableDirectory + -> Either DumpError Text.Builder.Builder +dumpTables processedState directory@FontDirectory{..} = + findRequired "hhea" hheaTableP >>= traverseDirectory where - go :: ParseErrorOrDump -> TableDirectory -> ParseErrorOrDump - go (Left accumulator) _ = Left accumulator - go (Right accumulator) tableEntry - = maybe (Right accumulator) (concatDump accumulator) - $ dumpSubTable tableEntry + traverseDirectory parsedHhea = + let initial = Right $ dumpOffsetTable directory + in foldl' (go parsedHhea) initial tableDirectory + findRequired tableName parser = + let missingError = Left $ DumpRequiredTableMissingError tableName + parseRequired tableEntry = parseTable tableEntry parser processedState + in maybe missingError (first DumpParseError . parseRequired) + $ find ((== Char8.pack tableName) . getField @"tag") tableDirectory + go _ (Left accumulator) _ = Left accumulator + go hheaTable (Right accumulator) tableEntry + = maybe (Right accumulator) (concatDump accumulator . first DumpParseError) + $ dumpSubTable hheaTable tableEntry concatDump accumulator builderDump = ((accumulator <> newlineBuilder) <>) <$> builderDump - dumpSubTable tableEntry = + dumpSubTable hheaTable@HheaTable{ numOfLongHorMetrics } tableEntry = case getField @"tag" tableEntry of "cmap" -> Just $ dumpCmap <$> parseTable tableEntry cmapTableP processedState "head" -> Just $ dumpHead <$> parseTable tableEntry headTableP processedState - "hhea" -> Just $ dumpHhea <$> parseTable tableEntry hheaTableP processedState + "hhea" -> Just $ Right $ dumpHhea hheaTable + "hmtx" -> Just $ dumpHmtx + <$> parseTable tableEntry (hmtxTableP numOfLongHorMetrics) processedState _ -> Nothing -dumpTrueType :: ByteString -> FilePath -> ParseErrorOrDump +dumpTrueType :: ByteString -> FilePath -> Either DumpError Text.Builder.Builder dumpTrueType ttfContents fontFile = let initialState = Megaparsec.State { stateInput = ttfContents @@ -314,4 +349,4 @@ dumpTrueType ttfContents fontFile = } (processedState, initialResult) = Megaparsec.runParser' fontDirectoryP initialState - in initialResult >>= dumpTables processedState + in first DumpParseError initialResult >>= dumpTables processedState diff --git a/src/Graphics/Fountainhead/Parser.hs b/src/Graphics/Fountainhead/Parser.hs index f39cbda..96209f7 100644 --- a/src/Graphics/Fountainhead/Parser.hs +++ b/src/Graphics/Fountainhead/Parser.hs @@ -337,9 +337,9 @@ longHorMetricP = LongHorMetric <$> Megaparsec.Binary.word16be <*> Megaparsec.Binary.int16be -hmtxTableP :: Int -> Parser HmtxTable +hmtxTableP :: Word16 -> Parser HmtxTable hmtxTableP numOfLongHorMetrics = HmtxTable - <$> countP numOfLongHorMetrics longHorMetricP + <$> countP (fromIntegral numOfLongHorMetrics) longHorMetricP <*> Megaparsec.many Megaparsec.Binary.int16be -- * Glyph name and PostScript font table @@ -928,7 +928,7 @@ parseTable -> Parser a -> Megaparsec.State ByteString Void -> Either (Megaparsec.ParseErrorBundle ByteString Void) a -parseTable TableDirectory{ offset, length } parser state = snd +parseTable TableDirectory{ offset, length = length' } parser state = snd $ Megaparsec.runParser' parser $ state { Megaparsec.stateInput = stateInput @@ -940,7 +940,7 @@ parseTable TableDirectory{ offset, length } parser state = snd } where posState = Megaparsec.statePosState state - stateInput = ByteString.take length + stateInput = ByteString.take length' $ ByteString.drop (offset - Megaparsec.stateOffset state) $ Megaparsec.stateInput state stateOffset = offset