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 #-}

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(..)
    , 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 = 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
    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."

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

            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