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

lib/Graphics/Fountainhead/TrueType.hs

@@ -4,7 +4,10 @@
 
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE ViewPatterns #-}
 
 -- | Types representing a TrueType font.
 module Graphics.Fountainhead.TrueType
@@ -85,6 +88,7 @@ module Graphics.Fountainhead.TrueType
     , findTableByTag
     , unLocaTable
     , nameStringOffset
+    , pattern Os2Version4CommonFields
     ) where
 
 import Data.ByteString (ByteString)
@@ -545,6 +549,21 @@ data Os2Table
     | Os2Version5 Os2BaseFields Os2MicrosoftFields Os2Version5Fields
     deriving (Eq, Show)
 
+pattern Os2Version4CommonFields :: Os2BaseFields -> Os2Version4Fields -> Os2Table
+pattern Os2Version4CommonFields baseFields versionFields <-
+    (os2Version4CommonFields -> Just (baseFields, versionFields))
+
+{-# COMPLETE Os2Version4CommonFields, Os2Version0, Os2Version1, Os2Version5 #-}
+
+os2Version4CommonFields :: Os2Table -> Maybe (Os2BaseFields, Os2Version4Fields)
+os2Version4CommonFields = \case
+    Os2Version0{} -> Nothing
+    Os2Version1{} -> Nothing
+    Os2Version2 baseFields _ versionFields -> Just (baseFields, versionFields)
+    Os2Version3 baseFields _ versionFields -> Just (baseFields, versionFields)
+    Os2Version4 baseFields _ versionFields -> Just (baseFields, versionFields)
+    Os2Version5{} -> Nothing
+
 data Os2Version1Fields = Os2Version1Fields
     { ulCodePageRange1 :: Word32
     , ulCodePageRange2 :: Word32