Extract metrics from the OS/2 table

lib/Graphics/Fountainhead/Metrics.hs

@@ -5,6 +5,7 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE PatternSynonyms #-}
 
 module Graphics.Fountainhead.Metrics
     ( FontBBox(..)
@@ -24,9 +25,14 @@ import Graphics.Fountainhead.TrueType
     , HheaTable(..)
     , NameRecord(..)
     , NameTable(..)
+    , Os2BaseFields(..)
+    , Os2Version4Fields(..)
+    , Os2Version5Fields(..)
+    , Os2Table(..)
     , PostHeader(..)
     , PostTable(..)
     , findTableByTag
+    , pattern Os2Version4CommonFields
     )
 import Graphics.Fountainhead.Parser
     ( ParseErrorBundle
@@ -35,14 +41,14 @@ import Graphics.Fountainhead.Parser
     , parseTable
     , headTableP
     , hheaTableP
+    , os2TableP
     , postTableP
     )
 import qualified Text.Megaparsec as Megaparsec
 import Data.Bifunctor (Bifunctor(..))
-import Data.Int (Int16, Int32)
+import Data.Int (Int16)
 import Data.Word (Word16)
 import GHC.Records (HasField(..))
-import Graphics.Fountainhead.Type (Fixed32(..))
 
 type Number = Float
 
@@ -99,6 +105,7 @@ data MetricsError
     = MetricsParseError ParseErrorBundle
     | MetricsRequiredTableMissingError String
     | MetricsNameRecordNotFound Word16
+    | UnsupportedOs2VersionError
     deriving Eq
 
 instance Show MetricsError
@@ -108,6 +115,8 @@ instance Show MetricsError
         "Required table " <> tableName <> " is missing."
     show (MetricsNameRecordNotFound nameId) =
         "Name record with ID " <> show nameId <> " was not found."
+    show UnsupportedOs2VersionError =
+        "OS/2 version 1 does not contain cap height."
 
 collectMetrics :: FilePath -> ByteString -> Either MetricsError FontDescriptor
 collectMetrics fontFile ttfContents =
@@ -138,18 +147,32 @@ collectMetrics fontFile ttfContents =
             PostTable{ postHeader } <- first MetricsParseError
                 $ parseTable postEntry postTableP processedState
 
+            (capHeight, weightClass) <- getCapHeight processedState initialResult
+
             pure $ FontDescriptor
                 { fontName = variableText nameRecord variable psNameIndex
                 , flags = []
-                , stemV = 1
+                , stemV = calculateStemV $ fromIntegral weightClass
                 , missingWidth = 0
                 , fontBBox =  calculateBoundingBox scale headTable
                 , italicAngle = realToFrac $ getField @"italicAngle" postHeader
-                , capHeight = 0
+                , capHeight = fromIntegral $ scalePs scale capHeight
                 , ascender = fromIntegral $ scalePs scale ascent
                 , descender = fromIntegral $ scalePs scale descent
                 }
   where
+    calculateStemV weightClass = 10 + 220 * (weightClass - 50) / 900
+    getCapHeight processedState initialResult = do
+        os2Entry <- maybeMetricsError (MetricsRequiredTableMissingError "OS/2")
+            $ findTableByTag "OS/2" initialResult
+        os2Table <- first MetricsParseError
+            $ parseTable os2Entry os2TableP processedState
+        case os2Table of
+            Os2Version4CommonFields Os2BaseFields{ usWeightClass } Os2Version4Fields{ sCapHeight } ->
+                Right (sCapHeight, usWeightClass)
+            Os2Version5 Os2BaseFields{ usWeightClass } _ Os2Version5Fields{ sCapHeight } ->
+                Right (sCapHeight, usWeightClass)
+            _ -> Left UnsupportedOs2VersionError
     calculateBoundingBox scale HeadTable{ xMin, xMax, yMin, yMax } =
         let xMin' = fromIntegral $ scalePs scale xMin
             yMin' = fromIntegral $ scalePs scale yMin