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

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

import Data.ByteString (ByteString)
import Data.Text (Text)
import Graphics.Fountainhead.TrueType (findTableByTag)
import Graphics.Fountainhead.Parser
    ( ParseErrorBundle
    , nameTableP
    , parseFontDirectory
    , parseTable
    )
import qualified Text.Megaparsec as Megaparsec

type Number = Double

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]
    , fullName :: Text
    , familyName :: Text
    , weight :: Text
    , fontBBox :: FontBBox
    , version :: Text
    , notice :: Text
    , encodingScheme :: Text
    , isFixedPitch :: Bool
    , ascender :: Number
    , descender :: Number
    } deriving (Eq, Show)

data MetricsError
    = MetricsParseError ParseErrorBundle
    | MetricsRequiredTableMissingError String
    deriving Eq

instance Show MetricsError
  where
    show (MetricsParseError errorBundle) = Megaparsec.errorBundlePretty errorBundle
    show (MetricsRequiredTableMissingError tableName) =
        "Required table " <> tableName <> " is missing."

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"