{-|
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 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

-- | 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
1 --dpr

  [Text]
validFonts <- ([Text] -> FontDef -> IO [Text])
-> [Text] -> [FontDef] -> IO [Text]
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

  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Text] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
validFonts) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    String -> IO ()
putStrLn String
"Could not find any valid fonts. Text size calculations will fail."
  
  FontManager -> IO FontManager
forall (m :: * -> *) a. Monad m => a -> m a
return (FontManager -> IO FontManager) -> FontManager -> IO FontManager
forall a b. (a -> b) -> a -> b
$ FMContext -> Double -> FontManager
newManager FMContext
ctx Double
dpr

newManager :: FMContext -> Double -> FontManager
newManager :: FMContext -> Double -> FontManager
newManager FMContext
ctx Double
dpr = FontManager :: (Font -> FontSize -> TextMetrics)
-> (Font -> FontSize -> FontSpace -> Text -> Size)
-> (Font -> FontSize -> FontSpace -> Text -> Seq GlyphPos)
-> FontManager
FontManager {Font -> FontSize -> TextMetrics
Font -> FontSize -> FontSpace -> Text -> Seq GlyphPos
Font -> FontSize -> FontSpace -> Text -> Size
computeGlyphsPos :: Font -> FontSize -> FontSpace -> Text -> Seq GlyphPos
computeTextSize :: Font -> FontSize -> FontSpace -> Text -> Size
computeTextMetrics :: Font -> FontSize -> TextMetrics
computeGlyphsPos :: Font -> FontSize -> FontSpace -> Text -> Seq GlyphPos
computeTextSize :: Font -> FontSize -> FontSpace -> Text -> Size
computeTextMetrics :: Font -> FontSize -> TextMetrics
..} where
  computeTextMetrics :: Font -> FontSize -> TextMetrics
computeTextMetrics Font
font FontSize
fontSize = IO TextMetrics -> TextMetrics
forall a. IO a -> a
unsafePerformIO (IO TextMetrics -> TextMetrics) -> IO TextMetrics -> TextMetrics
forall a b. (a -> b) -> a -> b
$ do
    FMContext -> Double -> Font -> FontSize -> FontSpace -> IO ()
setFont FMContext
ctx Double
dpr Font
font FontSize
fontSize FontSpace
forall a. Default a => a
def
    (Double
asc, Double
desc, Double
lineh) <- FMContext -> IO (Double, Double, Double)
fmTextMetrics FMContext
ctx
    Maybe GlyphPosition
lowerX <- Int -> Seq GlyphPosition -> Maybe GlyphPosition
forall a. Int -> Seq a -> Maybe a
Seq.lookup Int
0 (Seq GlyphPosition -> Maybe GlyphPosition)
-> IO (Seq GlyphPosition) -> IO (Maybe GlyphPosition)
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 CFloat -> CFloat -> CFloat
forall a. Num a => a -> a -> a
- GlyphPosition -> CFloat
glyphPosMinY GlyphPosition
lx
          Maybe GlyphPosition
Nothing -> Double -> CFloat
forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
asc

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

  computeTextSize :: Font -> FontSize -> FontSpace -> Text -> Size
computeTextSize Font
font FontSize
fontSize FontSpace
fontSpaceH Text
text = IO Size -> Size
forall a. IO a -> a
unsafePerformIO (IO Size -> Size) -> IO Size -> Size
forall a b. (a -> b) -> a -> b
$ do
    FMContext -> Double -> Font -> FontSize -> FontSpace -> IO ()
setFont FMContext
ctx Double
dpr Font
font FontSize
fontSize FontSpace
fontSpaceH
    (Double
x1, Double
y1, Double
x2, Double
y2) <- if Text
text Text -> Text -> Bool
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
        (Double, Double, Double, Double)
-> IO (Double, Double, Double, Double)
forall (m :: * -> *) a. Monad m => a -> m a
return (Double
0, Double
0, Double
0, Double
lineh)

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

  computeGlyphsPos :: Font -> FontSize -> FontSpace -> Text -> Seq GlyphPos
computeGlyphsPos Font
font FontSize
fontSize FontSpace
fontSpaceH Text
text = IO (Seq GlyphPos) -> Seq GlyphPos
forall a. IO a -> a
unsafePerformIO (IO (Seq GlyphPos) -> Seq GlyphPos)
-> IO (Seq GlyphPos) -> Seq GlyphPos
forall a b. (a -> b) -> a -> b
$ do
    FMContext -> Double -> Font -> FontSize -> FontSpace -> IO ()
setFont FMContext
ctx Double
dpr Font
font FontSize
fontSize FontSpace
fontSpaceH
    Seq GlyphPosition
glyphs <- if Text
text Text -> Text -> Bool
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 Seq GlyphPosition -> IO (Seq GlyphPosition)
forall (m :: * -> *) a. Monad m => a -> m a
return Seq GlyphPosition
forall a. Seq a
Seq.empty

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

loadFont :: FMContext -> [Text] -> FontDef -> IO [Text]
loadFont :: FMContext -> [Text] -> FontDef -> IO [Text]
loadFont FMContext
ctx [Text]
fonts (FontDef Text
name Text
path) = do
  Int
res <- FMContext -> Text -> Text -> IO Int
fmCreateFont FMContext
ctx Text
name Text
path
  if Int
res Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0
    then [Text] -> IO [Text]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Text] -> IO [Text]) -> [Text] -> IO [Text]
forall a b. (a -> b) -> a -> b
$ Text
path Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
fonts
    else String -> IO ()
putStrLn (String
"Failed to load font: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack Text
name) IO () -> IO [Text] -> IO [Text]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Text] -> IO [Text]
forall (m :: * -> *) a. Monad m => a -> m a
return [Text]
fonts

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