fountainhead/lib/Graphics/Fountainhead/Metrics.hs

{- This Source Code Form is subject to the terms of the Mozilla Public License,
   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 #-}
{-# LANGUAGE PatternSynonyms #-}

module Graphics.Fountainhead.Metrics
    ( FontBBox(..)
    , FontDescriptor(..)
    , MetricsError(..)
    , Number
    , FontDescriptorFlag(..)
    , collectMetrics
    ) where

import Data.ByteString (ByteString)
import Data.List (findIndex)
import Data.Text (Text)
import qualified Data.Text.Encoding as Text
import Graphics.Fountainhead.TrueType
    ( HeadTable(..)
    , HheaTable(..)
    , NameRecord(..)
    , NameTable(..)
    , Os2BaseFields(..)
    , Os2Version4Fields(..)
    , Os2Version5Fields(..)
    , Os2Table(..)
    , PostHeader(..)
    , PostTable(..)
    , findTableByTag
    , pattern Os2Version4CommonFields
    )
import Graphics.Fountainhead.Parser
    ( ParseErrorBundle
    , nameTableP
    , parseFontDirectory
    , parseTable
    , headTableP
    , hheaTableP
    , os2TableP
    , postTableP
    )
import qualified Text.Megaparsec as Megaparsec
import Data.Bifunctor (Bifunctor(..))
import Data.Int (Int16)
import Data.Word (Word16)
import GHC.Records (HasField(..))

type Number = Float

data FontDescriptorFlag
    = FixedPitch
    | Serif
    | Symbolic
    | Script
    | Nonsymbolic
    | Italic
    | AllCap
    | SmallCap
    | ForceBold
    deriving (Eq, Show)

instance Enum FontDescriptorFlag
  where
    toEnum 1 = FixedPitch
    toEnum 2 = Serif
    toEnum 3 = Symbolic
    toEnum 4 = Script
    toEnum 6 = Nonsymbolic
    toEnum 7 = Italic
    toEnum 17 = AllCap
    toEnum 18 = SmallCap
    toEnum 19 = ForceBold
    toEnum _ = error "Font description flag is not supported."
    fromEnum FixedPitch = 1
    fromEnum Serif = 2
    fromEnum Symbolic = 3
    fromEnum Script = 4
    fromEnum Nonsymbolic = 6
    fromEnum Italic = 7
    fromEnum AllCap = 17
    fromEnum SmallCap = 18
    fromEnum ForceBold = 19

data FontBBox = FontBBox Number Number Number Number
    deriving (Eq, Show)

data FontDescriptor = FontDescriptor
    { fontName :: Text
    , flags :: [FontDescriptorFlag]
    , stemV :: Number
    , missingWidth :: Number
    , fontBBox :: FontBBox
    , italicAngle :: Number
    , capHeight :: Number
    , ascender :: Number
    , descender :: Number
    } deriving (Eq, Show)

data MetricsError
    = MetricsParseError ParseErrorBundle
    | MetricsRequiredTableMissingError String
    | MetricsNameRecordNotFound Word16
    | UnsupportedOs2VersionError
    deriving Eq

instance Show MetricsError
  where
    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."
    show UnsupportedOs2VersionError =
        "OS/2 version 1 does not contain cap height."

collectMetrics :: FilePath -> ByteString -> Either MetricsError FontDescriptor
collectMetrics fontFile ttfContents =
    case parseFontDirectory fontFile ttfContents of
        (_processedState, Left initialResult) -> Left
            $ MetricsParseError initialResult
        (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

            (capHeight, weightClass) <- getCapHeight processedState initialResult

            pure $ FontDescriptor
                { fontName = variableText nameRecord variable psNameIndex
                , flags = []
                , stemV = calculateStemV $ fromIntegral weightClass
                , missingWidth = 0
                , fontBBox =  calculateBoundingBox scale headTable
                , italicAngle = realToFrac $ getField @"italicAngle" postHeader
                , 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
            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