Get missing width for the font metrics

.gitignore

@@ -1,4 +1,2 @@
 /dist-newstyle/
 /dist/
-
-/fonts/

README.md

@@ -40,3 +40,12 @@ fountainhead --help
 for help.
 
 ## Usage
+
+TrueType and OpenType fonts consist of a sequence of tables and various
+informations about the font are encoded in these tables. There are both
+required and optional tables. The first table is a font directory and it
+describes the overall structure of the font, what tables it contains and at what
+offset other tables can be found.
+
+This library doesn't parse the whole font at once. The font directory has to be
+parsed first and can be used then to parse further tables as needed.

lib/Graphics/Fountainhead/Metrics.hs

@@ -18,29 +18,38 @@ module Graphics.Fountainhead.Metrics
 
 import Data.ByteString (ByteString)
 import Data.List (findIndex)
+import qualified Data.List.NonEmpty as NonEmpty
 import Data.Text (Text)
 import qualified Data.Text.Encoding as Text
 import Graphics.Fountainhead.TrueType
-    ( HeadTable(..)
+    ( BSerifStyle(..)
+    , FontDirectory(..)
+    , HeadTable(..)
     , HheaTable(..)
+    , HmtxTable(..)
+    , LongHorMetric(..)
     , NameRecord(..)
     , NameTable(..)
     , Os2BaseFields(..)
     , Os2Version4Fields(..)
     , Os2Version5Fields(..)
     , Os2Table(..)
+    , Panose(..)
     , PostHeader(..)
     , PostTable(..)
     , findTableByTag
     , pattern Os2Version4CommonFields
     )
 import Graphics.Fountainhead.Parser
-    ( ParseErrorBundle
+    ( Parser
+    , ParseErrorBundle
+    , ParseState
     , nameTableP
     , parseFontDirectory
     , parseTable
     , headTableP
     , hheaTableP
+    , hmtxTableP
     , os2TableP
     , postTableP
     )
@@ -124,36 +133,34 @@ collectMetrics fontFile ttfContents =
         (_processedState, Left initialResult) -> Left
             $ MetricsParseError initialResult
         (processedState, Right initialResult) -> do
-            nameEntry <- maybeMetricsError (MetricsRequiredTableMissingError "name")
+            let parseForMetrics' = parseForMetrics processedState initialResult
-                $ findTableByTag "name" initialResult
+
-            NameTable{ nameRecord, variable } <- first MetricsParseError
+            NameTable{ nameRecord, variable } <- parseForMetrics' "name" nameTableP
-                $ parseTable nameEntry nameTableP processedState
             psNameIndex <- maybeMetricsError (MetricsNameRecordNotFound 6)
                 $ findIndex ((6 ==) . getField @"nameID") nameRecord
 
-            headEntry <- maybeMetricsError (MetricsRequiredTableMissingError "head")
+            headTable@HeadTable{ unitsPerEm } <- parseForMetrics' "head" headTableP
-                $ findTableByTag "head" initialResult
-            headTable@HeadTable{ unitsPerEm } <- first MetricsParseError
-                $ parseTable headEntry headTableP processedState
             let scale = (1000.0 :: Float) / fromIntegral unitsPerEm
 
-            hheaEntry <- maybeMetricsError (MetricsRequiredTableMissingError "hhea")
+            HheaTable{ ascent, descent, numOfLongHorMetrics } <-
-                $ findTableByTag "hhea" initialResult
+                parseForMetrics' "hhea" hheaTableP
-            HheaTable{ ascent, descent } <- first MetricsParseError
+            PostTable{ postHeader } <- parseForMetrics' "post" postTableP
-                $ parseTable hheaEntry hheaTableP processedState
 
-            postEntry <- maybeMetricsError (MetricsRequiredTableMissingError "post")
+            (capHeight, os2BaseFields) <- getCapHeight processedState initialResult
-                $ findTableByTag "post" initialResult
+            let Os2BaseFields{ usWeightClass, panose } = os2BaseFields
-            PostTable{ postHeader } <- first MetricsParseError
-                $ parseTable postEntry postTableP processedState
 
-            (capHeight, weightClass) <- getCapHeight processedState initialResult
+            HmtxTable{ hMetrics } <- parseForMetrics' "hmtx"
+                $ hmtxTableP numOfLongHorMetrics
+
+            let fixedPitchFlag = if getField @"isFixedPitch" postHeader > 0 then Just FixedPitch else Nothing
+                isSerifFlag = if isSerif $ getField @"bSerifStyle" panose then Just Serif else Nothing
 
             pure $ FontDescriptor
                 { fontName = variableText nameRecord variable psNameIndex
                 , flags = []
-                , stemV = calculateStemV $ fromIntegral weightClass
+                , stemV = calculateStemV $ fromIntegral usWeightClass
-                , missingWidth = 0
+                , missingWidth = fromIntegral $ scalePs scale
+                    $ getField @"advanceWidth" $ NonEmpty.head hMetrics
                 , fontBBox =  calculateBoundingBox scale headTable
                 , italicAngle = realToFrac $ getField @"italicAngle" postHeader
                 , capHeight = fromIntegral $ scalePs scale capHeight
@@ -163,15 +170,12 @@ collectMetrics fontFile ttfContents =
   where
     calculateStemV weightClass = 10 + 220 * (weightClass - 50) / 900
     getCapHeight processedState initialResult = do
-        os2Entry <- maybeMetricsError (MetricsRequiredTableMissingError "OS/2")
+        os2Table <- parseForMetrics processedState initialResult "OS/2" os2TableP
-            $ findTableByTag "OS/2" initialResult
-        os2Table <- first MetricsParseError
-            $ parseTable os2Entry os2TableP processedState
         case os2Table of
-            Os2Version4CommonFields Os2BaseFields{ usWeightClass } Os2Version4Fields{ sCapHeight } ->
+            Os2Version4CommonFields os2BaseFields Os2Version4Fields{ sCapHeight } ->
-                Right (sCapHeight, usWeightClass)
+                Right (sCapHeight, os2BaseFields)
-            Os2Version5 Os2BaseFields{ usWeightClass } _ Os2Version5Fields{ sCapHeight } ->
+            Os2Version5 os2BaseFields _ Os2Version5Fields{ sCapHeight } ->
-                Right (sCapHeight, usWeightClass)
+                Right (sCapHeight, os2BaseFields)
             _ -> Left UnsupportedOs2VersionError
     calculateBoundingBox scale HeadTable{ xMin, xMax, yMin, yMax } =
         let xMin' = fromIntegral $ scalePs scale xMin
@@ -179,7 +183,7 @@ collectMetrics fontFile ttfContents =
             xMax' = fromIntegral $ scalePs scale xMax
             yMax' = fromIntegral $ scalePs scale yMax
          in FontBBox xMin' yMin' xMax' yMax'
-    scalePs :: Float -> Int16 -> Int16
+    scalePs :: Integral a => Float -> a -> Int16
     scalePs scale value = truncate $ fromIntegral value * scale
     variableText records variables recordIndex =
         let NameRecord{ platformID } = records !! recordIndex
@@ -187,5 +191,39 @@ collectMetrics fontFile ttfContents =
          in if platformID == 1
             then Text.decodeUtf8 variable
             else Text.decodeUtf16BE variable
-    maybeMetricsError metricsError Nothing = Left metricsError
+
-    maybeMetricsError _ (Just result) = Right result
+parseForMetrics
+    :: forall a
+    . ParseState
+    -> FontDirectory
+    -> String
+    -> Parser a
+    -> Either MetricsError a
+parseForMetrics processedState fontDirectory tableName tableParser =
+    let foundTable = findTableByTag tableName fontDirectory
+        missingError = MetricsRequiredTableMissingError tableName
+        parseTable' rawTable = parseTable rawTable tableParser processedState
+     in maybeMetricsError missingError foundTable
+        >>= first MetricsParseError . parseTable'
+
+maybeMetricsError :: forall a. MetricsError -> Maybe a -> Either MetricsError a
+maybeMetricsError metricsError Nothing = Left metricsError
+maybeMetricsError _ (Just result) = Right result
+
+isSerif :: BSerifStyle -> Bool
+isSerif AnySerifStyle = False
+isSerif NoFitSerifStyle = False
+isSerif CoveSerifStyle = True
+isSerif ObtuseCoveSerifStyle = True
+isSerif SquareCoveSerifStyle = True
+isSerif ObtuseSquareCoveSerifStyle = True
+isSerif SquareSerifStyle = True
+isSerif ThinSerifStyle = True
+isSerif BoneSerifStyle = True
+isSerif ExaggeratedSerifStyle =True
+isSerif TriangleSerifStyle = True
+isSerif NormalSansSerifStyle = False
+isSerif ObtuseSansSerifStyle = False
+isSerif PerpSansSerifStyle = False
+isSerif FlaredSerifStyle = True
+isSerif RoundedSerifStyle = True

lib/Graphics/Fountainhead/TrueType.hs

@@ -276,7 +276,10 @@ data PostHeader = PostHeader
     , italicAngle :: Fixed32 -- ^ Italic angle in degrees
     , underlinePosition :: Int16 -- ^ Underline position
     , underlineThickness :: Int16 -- ^ Underline thickness
-    , isFixedPitch :: Word32 -- ^ Font is monospaced; set to 1 if the font is monospaced and 0 otherwise (N.B., to maintain compatibility with older versions of the TrueType spec, accept any non-zero value as meaning that the font is monospaced)
+    -- | Font is monospaced; set to 1 if the font is monospaced and 0 otherwise
+    -- (N.B., to maintain compatibility with older versions of the TrueType
+    -- spec, accept any non-zero value as meaning that the font is monospaced)
+    , isFixedPitch :: Word32
     , minMemType42 :: Word32 -- ^ Minimum memory usage when a TrueType font is downloaded as a Type 42 font
     , maxMemType42 :: Word32 -- ^ Maximum memory usage when a TrueType font is downloaded as a Type 42 font
     , minMemType1 :: Word32 -- ^ Minimum memory usage when a TrueType font is downloaded as a Type 1 font