{-|
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.Sequence (Seq)
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 :: [FontDef] -> Double -> IO FontManager
makeFontManager [FontDef]
fonts Double
dpr = do
  FMContext
ctx <- Double -> IO FMContext
fmInit Double
dpr

  [Text]
validFonts <- forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (FMContext -> [Text] -> FontDef -> IO [Text]
loadFont FMContext
ctx) [] [FontDef]
fonts

  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
validFonts) forall a b. (a -> b) -> a -> b
$
    [Char] -> IO ()
putStrLnErr [Char]
"Could not find any valid fonts. Text size calculations will fail."

  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ FMContext -> FontManager
newManager FMContext
ctx

newManager :: FMContext -> FontManager
newManager :: FMContext -> FontManager
newManager FMContext
ctx = FontManager {Double -> Font -> FontSize -> TextMetrics
Double -> Font -> FontSize -> FontSpace -> Text -> Seq GlyphPos
Double -> Font -> FontSize -> FontSpace -> Text -> Size
Font -> FontSize -> TextMetrics
Font -> FontSize -> FontSpace -> Text -> Seq GlyphPos
Font -> FontSize -> FontSpace -> Text -> Size
computeGlyphsPos_ :: Double -> Font -> FontSize -> FontSpace -> Text -> Seq GlyphPos
computeGlyphsPos :: Font -> FontSize -> FontSpace -> Text -> Seq GlyphPos
computeTextSize_ :: Double -> Font -> FontSize -> FontSpace -> Text -> Size
computeTextSize :: Font -> FontSize -> FontSpace -> Text -> Size
computeTextMetrics_ :: Double -> Font -> FontSize -> TextMetrics
computeTextMetrics :: Font -> FontSize -> TextMetrics
computeGlyphsPos_ :: Double -> Font -> FontSize -> FontSpace -> Text -> Seq GlyphPos
computeGlyphsPos :: Font -> FontSize -> FontSpace -> Text -> Seq GlyphPos
computeTextSize_ :: Double -> Font -> FontSize -> FontSpace -> Text -> Size
computeTextSize :: Font -> FontSize -> FontSpace -> Text -> Size
computeTextMetrics_ :: Double -> Font -> FontSize -> TextMetrics
computeTextMetrics :: Font -> FontSize -> TextMetrics
..} where
  computeTextMetrics :: Font -> FontSize -> TextMetrics
computeTextMetrics Font
font FontSize
fontSize =
    Double -> Font -> FontSize -> TextMetrics
computeTextMetrics_ Double
1 Font
font FontSize
fontSize

  computeTextMetrics_ :: Double -> Font -> FontSize -> TextMetrics
computeTextMetrics_ Double
scale Font
font FontSize
fontSize = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ do
    FMContext -> Double -> Font -> FontSize -> FontSpace -> IO ()
setFont FMContext
ctx Double
scale Font
font FontSize
fontSize forall a. Default a => a
def
    (Double
asc, Double
desc, Double
lineh) <- FMContext -> IO (Double, Double, Double)
fmTextMetrics FMContext
ctx
    Maybe GlyphPosition
lowerX <- forall a. Int -> Seq a -> Maybe a
Seq.lookup Int
0 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FMContext -> Double -> Double -> Text -> IO (Seq GlyphPosition)
fmTextGlyphPositions FMContext
ctx Double
0 Double
0 Text
"x"
    let heightLowerX :: CFloat
heightLowerX = case Maybe GlyphPosition
lowerX of
          Just GlyphPosition
lx -> GlyphPosition -> CFloat
glyphPosMaxY GlyphPosition
lx forall a. Num a => a -> a -> a
- GlyphPosition -> CFloat
glyphPosMinY GlyphPosition
lx
          Maybe GlyphPosition
Nothing -> forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
asc

    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ TextMetrics {
      _txmAsc :: Double
_txmAsc = Double
asc,
      _txmDesc :: Double
_txmDesc = Double
desc,
      _txmLineH :: Double
_txmLineH = Double
lineh,
      _txmLowerX :: Double
_txmLowerX = forall a b. (Real a, Fractional b) => a -> b
realToFrac CFloat
heightLowerX
    }

  computeTextSize :: Font -> FontSize -> FontSpace -> Text -> Size
computeTextSize Font
font FontSize
fontSize FontSpace
fontSpaceH Text
text =
    Double -> Font -> FontSize -> FontSpace -> Text -> Size
computeTextSize_ Double
1 Font
font FontSize
fontSize FontSpace
fontSpaceH Text
text

  computeTextSize_ :: Double -> Font -> FontSize -> FontSpace -> Text -> Size
computeTextSize_ Double
scale Font
font FontSize
fontSize FontSpace
fontSpaceH Text
text = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ do
    FMContext -> Double -> Font -> FontSize -> FontSpace -> IO ()
setFont FMContext
ctx Double
scale Font
font FontSize
fontSize FontSpace
fontSpaceH
    (Double
x1, Double
y1, Double
x2, Double
y2) <- if Text
text forall a. Eq a => a -> a -> Bool
/= Text
""
      then FMContext
-> Double -> Double -> Text -> IO (Double, Double, Double, Double)
fmTextBounds FMContext
ctx Double
0 Double
0 Text
text
      else do
        (Double
asc, Double
desc, Double
lineh) <- FMContext -> IO (Double, Double, Double)
fmTextMetrics FMContext
ctx
        forall (m :: * -> *) a. Monad m => a -> m a
return (Double
0, Double
0, Double
0, Double
lineh)

    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Double -> Double -> Size
Size (forall a b. (Real a, Fractional b) => a -> b
realToFrac (Double
x2 forall a. Num a => a -> a -> a
- Double
x1)) (forall a b. (Real a, Fractional b) => a -> b
realToFrac (Double
y2 forall a. Num a => a -> a -> a
- Double
y1))

  computeGlyphsPos :: Font -> FontSize -> FontSpace -> Text -> Seq GlyphPos
computeGlyphsPos Font
font FontSize
fontSize FontSpace
fontSpaceH Text
text =
    Double -> Font -> FontSize -> FontSpace -> Text -> Seq GlyphPos
computeGlyphsPos_ Double
1 Font
font FontSize
fontSize FontSpace
fontSpaceH Text
text

  computeGlyphsPos_ :: Double -> Font -> FontSize -> FontSpace -> Text -> Seq GlyphPos
computeGlyphsPos_ Double
scale Font
font FontSize
fontSize FontSpace
fontSpaceH Text
text = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ do
    FMContext -> Double -> Font -> FontSize -> FontSpace -> IO ()
setFont FMContext
ctx Double
scale Font
font FontSize
fontSize FontSpace
fontSpaceH
    Seq GlyphPosition
glyphs <- if Text
text forall a. Eq a => a -> a -> Bool
/= Text
""
      then FMContext -> Double -> Double -> Text -> IO (Seq GlyphPosition)
fmTextGlyphPositions FMContext
ctx Double
0 Double
0 Text
text
      else forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Seq a
Seq.empty

    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> Seq a -> Seq b -> Seq c
Seq.zipWith Char -> GlyphPosition -> GlyphPos
toGlyphPos (forall a. [a] -> Seq a
Seq.fromList (Text -> [Char]
T.unpack Text
text)) Seq GlyphPosition
glyphs
    where
      toGlyphPos :: Char -> GlyphPosition -> GlyphPos
toGlyphPos Char
chr GlyphPosition
glyph = GlyphPos {
        _glpGlyph :: Char
_glpGlyph = Char
chr,
        _glpX :: Double
_glpX = forall a b. (Real a, Fractional b) => a -> b
realToFrac (GlyphPosition -> CFloat
glyphX GlyphPosition
glyph),
        _glpXMin :: Double
_glpXMin = forall a b. (Real a, Fractional b) => a -> b
realToFrac (GlyphPosition -> CFloat
glyphPosMinX GlyphPosition
glyph),
        _glpXMax :: Double
_glpXMax = forall a b. (Real a, Fractional b) => a -> b
realToFrac (GlyphPosition -> CFloat
glyphPosMaxX GlyphPosition
glyph),
        _glpYMin :: Double
_glpYMin = forall a b. (Real a, Fractional b) => a -> b
realToFrac (GlyphPosition -> CFloat
glyphPosMinY GlyphPosition
glyph),
        _glpYMax :: Double
_glpYMax = forall a b. (Real a, Fractional b) => a -> b
realToFrac (GlyphPosition -> CFloat
glyphPosMaxY GlyphPosition
glyph),
        _glpW :: Double
_glpW = forall a b. (Real a, Fractional b) => a -> b
realToFrac (GlyphPosition -> CFloat
glyphPosMaxX GlyphPosition
glyph forall a. Num a => a -> a -> a
- GlyphPosition -> CFloat
glyphPosMinX GlyphPosition
glyph),
        _glpH :: Double
_glpH = forall a b. (Real a, Fractional b) => a -> b
realToFrac (GlyphPosition -> CFloat
glyphPosMaxY GlyphPosition
glyph forall a. Num a => a -> a -> a
- GlyphPosition -> CFloat
glyphPosMinY GlyphPosition
glyph)
      }

loadFont :: FMContext -> [Text] -> FontDef -> IO [Text]
loadFont :: FMContext -> [Text] -> FontDef -> IO [Text]
loadFont FMContext
ctx [Text]
fonts FontDef
fontDef = do
  Int
res <- FontDef -> IO Int
createFont FontDef
fontDef
  if Int
res forall a. Ord a => a -> a -> Bool
>= Int
0
    then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text
name forall a. a -> [a] -> [a]
: [Text]
fonts
    else [Char] -> IO ()
putStrLnErr ([Char]
"Failed to load font: " forall a. [a] -> [a] -> [a]
++ Text -> [Char]
T.unpack Text
name) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return [Text]
fonts
  where
    name :: Text
name = FontDef
fontDef forall s a. s -> Getting a s a -> a
^. forall s a. HasFontName s a => Lens' s a
fontName
    createFont :: FontDef -> IO Int
createFont FontDefFile{} = FMContext -> Text -> Text -> IO Int
fmCreateFont FMContext
ctx Text
name (FontDef
fontDef forall s a. s -> Getting a s a -> a
^. forall s a. HasFontPath s a => Traversal' s a
fontPath)
    createFont FontDefMem{} = FMContext -> Text -> ByteString -> IO Int
fmCreateFontMem FMContext
ctx Text
name (FontDef
fontDef forall s a. s -> Getting a s a -> a
^. forall s a. HasFontBytes s a => Traversal' s a
fontBytes)

setFont :: FMContext -> Double -> Font -> FontSize -> FontSpace -> IO ()
setFont :: FMContext -> Double -> Font -> FontSize -> FontSpace -> IO ()
setFont FMContext
ctx Double
scale (Font Text
name) (FontSize Double
size) (FontSpace Double
spaceH) = do
  FMContext -> Double -> IO ()
fmSetScale FMContext
ctx Double
scale
  FMContext -> Text -> IO ()
fmFontFace FMContext
ctx Text
name
  FMContext -> Double -> IO ()
fmFontSize FMContext
ctx forall a b. (a -> b) -> a -> b
$ forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
size
  FMContext -> Double -> IO ()
fmTextLetterSpacing FMContext
ctx forall a b. (a -> b) -> a -> b
$ forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
spaceH