Add Fixed32 numeric instances

lib/Graphics/Fountainhead/Metrics.hs

@@ -2,7 +2,9 @@
    v. 2.0. If a copy of the MPL was not distributed with this file, You can
    obtain one at https://mozilla.org/MPL/2.0/. -}
 
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DuplicateRecordFields #-}
 
 module Graphics.Fountainhead.Metrics
     ( FontBBox(..)
@@ -14,17 +16,35 @@ module Graphics.Fountainhead.Metrics
     ) where
 
 import Data.ByteString (ByteString)
+import Data.List (findIndex)
 import Data.Text (Text)
-import Graphics.Fountainhead.TrueType (findTableByTag)
+import qualified Data.Text.Encoding as Text
+import Graphics.Fountainhead.TrueType
+    ( HeadTable(..)
+    , HheaTable(..)
+    , NameRecord(..)
+    , NameTable(..)
+    , PostHeader(..)
+    , PostTable(..)
+    , findTableByTag
+    )
 import Graphics.Fountainhead.Parser
     ( ParseErrorBundle
     , nameTableP
     , parseFontDirectory
     , parseTable
+    , headTableP
+    , hheaTableP
+    , postTableP
     )
 import qualified Text.Megaparsec as Megaparsec
+import Data.Bifunctor (Bifunctor(..))
+import Data.Int (Int16, Int32)
+import Data.Word (Word16)
+import GHC.Records (HasField(..))
+import Graphics.Fountainhead.Type (Fixed32(..))
 
-type Number = Double
+type Number = Float
 
 data FontDescriptorFlag
     = FixedPitch
@@ -66,14 +86,11 @@ data FontBBox = FontBBox Number Number Number Number
 data FontDescriptor = FontDescriptor
     { fontName :: Text
     , flags :: [FontDescriptorFlag]
-    , fullName :: Text
-    , familyName :: Text
-    , weight :: Text
+    , stemV :: Number
+    , missingWidth :: Number
     , fontBBox :: FontBBox
-    , version :: Text
-    , notice :: Text
-    , encodingScheme :: Text
-    , isFixedPitch :: Bool
+    , italicAngle :: Number
+    , capHeight :: Number
     , ascender :: Number
     , descender :: Number
     } deriving (Eq, Show)
@@ -81,6 +98,7 @@ data FontDescriptor = FontDescriptor
 data MetricsError
     = MetricsParseError ParseErrorBundle
     | MetricsRequiredTableMissingError String
+    | MetricsNameRecordNotFound Word16
     deriving Eq
 
 instance Show MetricsError
@@ -88,16 +106,63 @@ instance Show MetricsError
     show (MetricsParseError errorBundle) = Megaparsec.errorBundlePretty errorBundle
     show (MetricsRequiredTableMissingError tableName) =
         "Required table " <> tableName <> " is missing."
+    show (MetricsNameRecordNotFound nameId) =
+        "Name record with ID " <> show nameId <> " was not found."
 
 collectMetrics :: FilePath -> ByteString -> Either MetricsError FontDescriptor
 collectMetrics fontFile ttfContents =
     case parseFontDirectory fontFile ttfContents of
         (_processedState, Left initialResult) -> Left
             $ MetricsParseError initialResult
-        (processedState, Right initialResult)
-            | Just tableEntry <- findTableByTag "name" initialResult
-            , Right parsedNameTable <- parseTable tableEntry nameTableP processedState ->
-                pure $ FontDescriptor
-                    {
-                    }
-            | otherwise -> Left $ MetricsRequiredTableMissingError "name"
+        (processedState, Right initialResult) -> do
+            nameEntry <- maybeMetricsError (MetricsRequiredTableMissingError "name")
+                $ findTableByTag "name" initialResult
+            NameTable{ nameRecord, variable } <- first MetricsParseError
+                $ parseTable nameEntry nameTableP processedState
+            psNameIndex <- maybeMetricsError (MetricsNameRecordNotFound 6)
+                $ findIndex ((6 ==) . getField @"nameID") nameRecord
+
+            headEntry <- maybeMetricsError (MetricsRequiredTableMissingError "head")
+                $ findTableByTag "head" initialResult
+            headTable@HeadTable{ unitsPerEm } <- first MetricsParseError
+                $ parseTable headEntry headTableP processedState
+            let scale = (1000.0 :: Float) / fromIntegral unitsPerEm
+
+            hheaEntry <- maybeMetricsError (MetricsRequiredTableMissingError "hhea")
+                $ findTableByTag "hhea" initialResult
+            HheaTable{ ascent, descent } <- first MetricsParseError
+                $ parseTable hheaEntry hheaTableP processedState
+
+            postEntry <- maybeMetricsError (MetricsRequiredTableMissingError "post")
+                $ findTableByTag "post" initialResult
+            PostTable{ postHeader } <- first MetricsParseError
+                $ parseTable postEntry postTableP processedState
+
+            pure $ FontDescriptor
+                { fontName = variableText nameRecord variable psNameIndex
+                , flags = []
+                , stemV = 1
+                , missingWidth = 0
+                , fontBBox =  calculateBoundingBox scale headTable
+                , italicAngle = realToFrac $ getField @"italicAngle" postHeader
+                , capHeight = 0
+                , ascender = fromIntegral $ scalePs scale ascent
+                , descender = fromIntegral $ scalePs scale descent
+                }
+  where
+    calculateBoundingBox scale HeadTable{ xMin, xMax, yMin, yMax } =
+        let xMin' = fromIntegral $ scalePs scale xMin
+            yMin' = fromIntegral $ scalePs scale yMin
+            xMax' = fromIntegral $ scalePs scale xMax
+            yMax' = fromIntegral $ scalePs scale yMax
+         in FontBBox xMin' yMin' xMax' yMax'
+    scalePs :: Float -> Int16 -> Int16
+    scalePs scale value = truncate $ fromIntegral value * scale
+    variableText records variables recordIndex =
+        let NameRecord{ platformID } = records !! recordIndex
+            variable = variables !! recordIndex
+         in if platformID == 1
+            then Text.decodeUtf8 variable
+            else Text.decodeUtf16BE variable
+    maybeMetricsError metricsError Nothing = Left metricsError
+    maybeMetricsError _ (Just result) = Right result