FontManager.hs

{-|
Module      : Monomer.Graphics.FontManager
Copyright   : (c) 2018 Francisco Vallarino
License     : BSD-3-Clause (see the LICENSE file)
Maintainer  : fjvallarino@gmail.com
Stability   : experimental
Portability : non-portable

Provides functions for getting text dimensions and metrics.
-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE Strict #-}

module Monomer.Graphics.FontManager (
  makeFontManager
) where

import Control.Monad (foldM, when)
import Control.Lens ((^.))

import Data.Default
import Data.Text (Text)
import System.IO.Unsafe

import qualified Data.Sequence as Seq
import qualified Data.Text as T

import Monomer.Common.BasicTypes
import Monomer.Graphics.FFI
import Monomer.Graphics.Types
import Monomer.Helper (putStrLnErr)
import Monomer.Graphics.Lens (fontName, fontPath, fontBytes)

-- | Creates a font manager instance.
makeFontManager
  :: [FontDef]       -- ^ The font definitions.
  -> Double          -- ^ The device pixel rate.
  -> IO FontManager  -- ^ The created renderer.
makeFontManager fonts dpr = do
  ctx <- fmInit dpr

  validFonts <- foldM (loadFont ctx) [] fonts

  when (null validFonts) $
    putStrLnErr "Could not find any valid fonts. Text size calculations will fail."

  return $ newManager ctx

newManager :: FMContext -> FontManager
newManager ctx = FontManager {..} where
  computeTextMetrics font fontSize =
    computeTextMetrics_ 1 font fontSize

  computeTextMetrics_ scale font fontSize = unsafePerformIO $ do
    setFont ctx scale font fontSize def
    (asc, desc, lineh) <- fmTextMetrics ctx
    lowerX <- Seq.lookup 0 <$> fmTextGlyphPositions ctx 0 0 "x"
    let heightLowerX = case lowerX of
          Just lx -> glyphPosMaxY lx - glyphPosMinY lx
          Nothing -> realToFrac asc

    return $ TextMetrics {
      _txmAsc = asc,
      _txmDesc = desc,
      _txmLineH = lineh,
      _txmLowerX = realToFrac heightLowerX
    }

  computeTextSize font fontSize fontSpaceH text =
    computeTextSize_ 1 font fontSize fontSpaceH text

  computeTextSize_ scale font fontSize fontSpaceH text = unsafePerformIO $ do
    setFont ctx scale font fontSize fontSpaceH
    (x1, y1, x2, y2) <- if text /= ""
      then fmTextBounds ctx 0 0 text
      else do
        (asc, desc, lineh) <- fmTextMetrics ctx
        return (0, 0, 0, lineh)

    return $ Size (realToFrac (x2 - x1)) (realToFrac (y2 - y1))

  computeGlyphsPos font fontSize fontSpaceH text =
    computeGlyphsPos_ 1 font fontSize fontSpaceH text

  computeGlyphsPos_ scale font fontSize fontSpaceH text = unsafePerformIO $ do
    setFont ctx scale font fontSize fontSpaceH
    glyphs <- if text /= ""
      then fmTextGlyphPositions ctx 0 0 text
      else return Seq.empty

    return $ Seq.zipWith toGlyphPos (Seq.fromList (T.unpack text)) glyphs
    where
      toGlyphPos chr glyph = GlyphPos {
        _glpGlyph = chr,
        _glpX = realToFrac (glyphX glyph),
        _glpXMin = realToFrac (glyphPosMinX glyph),
        _glpXMax = realToFrac (glyphPosMaxX glyph),
        _glpYMin = realToFrac (glyphPosMinY glyph),
        _glpYMax = realToFrac (glyphPosMaxY glyph),
        _glpW = realToFrac (glyphPosMaxX glyph - glyphPosMinX glyph),
        _glpH = realToFrac (glyphPosMaxY glyph - glyphPosMinY glyph)
      }

loadFont :: FMContext -> [Text] -> FontDef -> IO [Text]
loadFont ctx fonts fontDef = do
  res <- createFont fontDef
  if res >= 0
    then return $ name : fonts
    else putStrLnErr ("Failed to load font: " ++ T.unpack name) >> return fonts
  where
    name = fontDef ^. fontName
    createFont FontDefFile{} = fmCreateFont ctx name (fontDef ^. fontPath)
    createFont FontDefMem{} = fmCreateFontMem ctx name (fontDef ^. fontBytes)

setFont :: FMContext -> Double -> Font -> FontSize -> FontSpace -> IO ()
setFont ctx scale (Font name) (FontSize size) (FontSpace spaceH) = do
  fmSetScale ctx scale
  fmFontFace ctx name
  fmFontSize ctx $ realToFrac size
  fmTextLetterSpacing ctx $ realToFrac spaceH