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 qualified Data.List.NonEmpty as NonEmpty
import Data.Text (Text)
import qualified Data.Text.Encoding as Text
import Graphics.Fountainhead.TrueType
    ( BSerifStyle(..)
    , FontDirectory(..)
    , HeadTable(..)
    , HheaTable(..)
    , HmtxTable(..)
    , LongHorMetric(..)
    , NameRecord(..)
    , NameTable(..)
    , Os2BaseFields(..)
    , Os2Version4Fields(..)
    , Os2Version5Fields(..)
    , Os2Table(..)
    , Panose(..)
    , PostHeader(..)
    , PostTable(..)
    , findTableByTag
    , pattern Os2Version4CommonFields
    )
import Graphics.Fountainhead.Parser
    ( Parser
    , ParseErrorBundle
    , ParseState
    , nameTableP
    , parseFontDirectory
    , parseTable
    , headTableP
    , hheaTableP
    , hmtxTableP
    , 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
            let parseForMetrics' = parseForMetrics processedState initialResult

            NameTable{ nameRecord, variable } <- parseForMetrics' "name" nameTableP
            psNameIndex <- maybeMetricsError (MetricsNameRecordNotFound 6)
                $ findIndex ((6 ==) . getField @"nameID") nameRecord

            headTable@HeadTable{ unitsPerEm } <- parseForMetrics' "head" headTableP
            let scale = (1000.0 :: Float) / fromIntegral unitsPerEm

            HheaTable{ ascent, descent, numOfLongHorMetrics } <-
                parseForMetrics' "hhea" hheaTableP
            PostTable{ postHeader } <- parseForMetrics' "post" postTableP

            (capHeight, os2BaseFields) <- getCapHeight processedState initialResult
            let Os2BaseFields{ usWeightClass, panose } = os2BaseFields

            HmtxTable{ hMetrics } <- parseForMetrics' "hmtx"
                $ hmtxTableP numOfLongHorMetrics

            let fixedPitchFlag = if getField @"isFixedPitch" postHeader > 0 then Just FixedPitch else Nothing
                isSerifFlag = if isSerif $ getField @"bSerifStyle" panose then Just Serif else Nothing

            pure $ FontDescriptor
                { fontName = variableText nameRecord variable psNameIndex
                , flags = []
                , stemV = calculateStemV $ fromIntegral usWeightClass
                , missingWidth = fromIntegral $ scalePs scale
                    $ getField @"advanceWidth" $ NonEmpty.head hMetrics
                , 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
        os2Table <- parseForMetrics processedState initialResult "OS/2" os2TableP
        case os2Table of
            Os2Version4CommonFields os2BaseFields Os2Version4Fields{ sCapHeight } ->
                Right (sCapHeight, os2BaseFields)
            Os2Version5 os2BaseFields _ Os2Version5Fields{ sCapHeight } ->
                Right (sCapHeight, os2BaseFields)
            _ -> 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 :: Integral a => Float -> a -> 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

parseForMetrics
    :: forall a
    . ParseState
    -> FontDirectory
    -> String
    -> Parser a
    -> Either MetricsError a
parseForMetrics processedState fontDirectory tableName tableParser =
    let foundTable = findTableByTag tableName fontDirectory
        missingError = MetricsRequiredTableMissingError tableName
        parseTable' rawTable = parseTable rawTable tableParser processedState
     in maybeMetricsError missingError foundTable
        >>= first MetricsParseError . parseTable'

maybeMetricsError :: forall a. MetricsError -> Maybe a -> Either MetricsError a
maybeMetricsError metricsError Nothing = Left metricsError
maybeMetricsError _ (Just result) = Right result

isSerif :: BSerifStyle -> Bool
isSerif AnySerifStyle = False
isSerif NoFitSerifStyle = False
isSerif CoveSerifStyle = True
isSerif ObtuseCoveSerifStyle = True
isSerif SquareCoveSerifStyle = True
isSerif ObtuseSquareCoveSerifStyle = True
isSerif SquareSerifStyle = True
isSerif ThinSerifStyle = True
isSerif BoneSerifStyle = True
isSerif ExaggeratedSerifStyle =True
isSerif TriangleSerifStyle = True
isSerif NormalSansSerifStyle = False
isSerif ObtuseSansSerifStyle = False
isSerif PerpSansSerifStyle = False
isSerif FlaredSerifStyle = True
isSerif RoundedSerifStyle = True