{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE RankNTypes                 #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE RecordWildCards            #-}
{-# LANGUAGE StandaloneDeriving         #-}
-- |
-- Module:     Typograffiti.Monad
-- Copyright:  (c) 2018 Schell Scivally, 2023 Adrian Cochrane
-- License:    MIT
-- Maintainer: Schell Scivally <schell@takt.com>
--             & Adrian Cochrane <alcinnz@argonaut-constellation.org>
--
-- A storage context an ops for rendering text with multiple fonts
-- and sizes, hiding the details of the Atlas, Cache, and the Harfbuzz library.
module Typograffiti.Store where


import           Control.Concurrent.STM (TMVar, atomically, newTMVar, putTMVar,
                                         readTMVar, takeTMVar)
import           Control.Monad.Except   (MonadError (..), runExceptT, ExceptT (..))
import           Control.Monad.IO.Class (MonadIO (..))
import           Control.Monad.Fail     (MonadFail (..))
import           Control.Monad          (unless, forM)
import           Data.Map               (Map)
import qualified Data.Map               as M
import qualified Data.IntSet            as IS
import qualified Data.ByteString        as B
import           Data.Text.Glyphize     (defaultBuffer, Buffer(..), shape,
                                        GlyphInfo(..), GlyphPos(..), FontOptions)
import qualified Data.Text.Glyphize     as HB
import qualified Data.Text.Lazy         as Txt
import           Foreign.Storable       (peek)
import           FreeType.Core.Base
import           FreeType.Core.Types    (FT_Fixed, FT_UShort)
import           FreeType.Format.Multiple (ft_Set_Var_Design_Coordinates)

import           Typograffiti.Atlas
import           Typograffiti.Cache
import           Typograffiti.Text      (GlyphSize(..), drawLinesWrapper, SampleText(..))
import           Typograffiti.Rich      (RichText(..))

-- | Stored fonts at specific sizes.
data FontStore n = FontStore {
    forall (n :: * -> *).
FontStore n
-> TMVar (Map (FilePath, GlyphSize, Int, FontOptions) Font)
fontMap :: TMVar (Map (FilePath, GlyphSize, Int, FontOptions) Font),
    -- ^ Map for looking up previously-opened fonts & their atlases.
    forall (n :: * -> *).
FontStore n
-> Atlas
-> [(GlyphInfo, GlyphPos)]
-> n (AllocatedRendering [TextTransform])
drawGlyphs :: Atlas -> [(GlyphInfo, GlyphPos)] -> n (AllocatedRendering [TextTransform]),
    -- ^ Cached routine for compositing from the given atlas.
    forall (n :: * -> *). FontStore n -> FT_Library
lib :: FT_Library
    -- ^ Globals for FreeType.
  }
-- | An opened font. In Harfbuzz, FreeType, & Atlas formats.
data Font = Font {
    Font -> Font
harfbuzz :: HB.Font,
    -- ^ Font as represented by Harfbuzz.
    Font -> FT_Face
freetype :: FT_Face,
    -- ^ Font as represented by FreeType.
    Font -> TMVar [(IntSet, Atlas)]
atlases :: TMVar [(IS.IntSet, Atlas)],
    -- ^ Glyphs from the font rendered into GPU atleses.
    Font -> Float
lineHeight :: Float,
    -- ^ Default lineheight for this font.
    Font -> (Float, Float)
fontScale :: (Float, Float)
    -- ^ Scaling parameters for Harfbuzz layout.
  }

-- | Opens a font sized to given value & prepare to render text in it.
-- The fonts are cached for later reuse.
makeDrawTextCached :: (MonadIO m, MonadFail m, MonadError TypograffitiError m,
    MonadIO n, MonadFail n, MonadError TypograffitiError n) =>
    FontStore n -> FilePath -> Int -> GlyphSize -> SampleText ->
    m (RichText -> n (AllocatedRendering [TextTransform]))
makeDrawTextCached :: forall (m :: * -> *) (n :: * -> *).
(MonadIO m, MonadFail m, MonadError TypograffitiError m, MonadIO n,
 MonadFail n, MonadError TypograffitiError n) =>
FontStore n
-> FilePath
-> Int
-> GlyphSize
-> SampleText
-> m (RichText -> n (AllocatedRendering [TextTransform]))
makeDrawTextCached FontStore n
store FilePath
filepath Int
index GlyphSize
fontsize SampleText {Float
Int
[Feature]
Text
FontOptions
minLineHeight :: SampleText -> Float
fontOptions :: SampleText -> FontOptions
tabwidth :: SampleText -> Int
sampleText :: SampleText -> Text
sampleFeatures :: SampleText -> [Feature]
minLineHeight :: Float
fontOptions :: FontOptions
tabwidth :: Int
sampleText :: Text
sampleFeatures :: [Feature]
..} = do
    Map (FilePath, GlyphSize, Int, FontOptions) Font
s <- IO (Map (FilePath, GlyphSize, Int, FontOptions) Font)
-> m (Map (FilePath, GlyphSize, Int, FontOptions) Font)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Map (FilePath, GlyphSize, Int, FontOptions) Font)
 -> m (Map (FilePath, GlyphSize, Int, FontOptions) Font))
-> IO (Map (FilePath, GlyphSize, Int, FontOptions) Font)
-> m (Map (FilePath, GlyphSize, Int, FontOptions) Font)
forall a b. (a -> b) -> a -> b
$ STM (Map (FilePath, GlyphSize, Int, FontOptions) Font)
-> IO (Map (FilePath, GlyphSize, Int, FontOptions) Font)
forall a. STM a -> IO a
atomically (STM (Map (FilePath, GlyphSize, Int, FontOptions) Font)
 -> IO (Map (FilePath, GlyphSize, Int, FontOptions) Font))
-> STM (Map (FilePath, GlyphSize, Int, FontOptions) Font)
-> IO (Map (FilePath, GlyphSize, Int, FontOptions) Font)
forall a b. (a -> b) -> a -> b
$ TMVar (Map (FilePath, GlyphSize, Int, FontOptions) Font)
-> STM (Map (FilePath, GlyphSize, Int, FontOptions) Font)
forall a. TMVar a -> STM a
readTMVar (TMVar (Map (FilePath, GlyphSize, Int, FontOptions) Font)
 -> STM (Map (FilePath, GlyphSize, Int, FontOptions) Font))
-> TMVar (Map (FilePath, GlyphSize, Int, FontOptions) Font)
-> STM (Map (FilePath, GlyphSize, Int, FontOptions) Font)
forall a b. (a -> b) -> a -> b
$ FontStore n
-> TMVar (Map (FilePath, GlyphSize, Int, FontOptions) Font)
forall (n :: * -> *).
FontStore n
-> TMVar (Map (FilePath, GlyphSize, Int, FontOptions) Font)
fontMap FontStore n
store
    let fontOpts' :: FontOptions
fontOpts' = FontOptions
fontOptions {
        optionScale :: Maybe (Int, Int)
HB.optionScale = Maybe (Int, Int)
forall a. Maybe a
Nothing, optionPtEm :: Maybe Float
HB.optionPtEm = Maybe Float
forall a. Maybe a
Nothing, optionPPEm :: Maybe (Word, Word)
HB.optionPPEm = Maybe (Word, Word)
forall a. Maybe a
Nothing
      }
    Font
font <- case (FilePath, GlyphSize, Int, FontOptions)
-> Map (FilePath, GlyphSize, Int, FontOptions) Font -> Maybe Font
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (FilePath
filepath, GlyphSize
fontsize, Int
index, FontOptions
fontOpts') Map (FilePath, GlyphSize, Int, FontOptions) Font
s of
        Maybe Font
Nothing -> FontStore n
-> FilePath -> Int -> GlyphSize -> FontOptions -> m Font
forall (m :: * -> *) (n :: * -> *).
(MonadIO m, MonadError TypograffitiError m) =>
FontStore n
-> FilePath -> Int -> GlyphSize -> FontOptions -> m Font
allocFont FontStore n
store FilePath
filepath Int
index GlyphSize
fontsize FontOptions
fontOpts'
        Just Font
font -> Font -> m Font
forall (m :: * -> *) a. Monad m => a -> m a
return Font
font

    let glyphs :: [Word32]
glyphs = ((GlyphInfo, GlyphPos) -> Word32)
-> [(GlyphInfo, GlyphPos)] -> [Word32]
forall a b. (a -> b) -> [a] -> [b]
map (GlyphInfo -> Word32
codepoint (GlyphInfo -> Word32)
-> ((GlyphInfo, GlyphPos) -> GlyphInfo)
-> (GlyphInfo, GlyphPos)
-> Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GlyphInfo, GlyphPos) -> GlyphInfo
forall a b. (a, b) -> a
fst) ([(GlyphInfo, GlyphPos)] -> [Word32])
-> [(GlyphInfo, GlyphPos)] -> [Word32]
forall a b. (a -> b) -> a -> b
$
            Font -> Buffer -> [Feature] -> [(GlyphInfo, GlyphPos)]
shape (Font -> Font
harfbuzz Font
font) Buffer
defaultBuffer {
                text :: Text
HB.text = Int64 -> Text -> Text
Txt.replicate (Int -> Int64
forall a. Enum a => Int -> a
toEnum (Int -> Int64) -> Int -> Int64
forall a b. (a -> b) -> a -> b
$ Int -> Int
forall a. Enum a => a -> a
succ (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ [Feature] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Feature]
sampleFeatures) Text
sampleText
            } [Feature]
sampleFeatures
    let glyphset :: IntSet
glyphset = [Int] -> IntSet
IS.fromList ([Int] -> IntSet) -> [Int] -> IntSet
forall a b. (a -> b) -> a -> b
$ (Word32 -> Int) -> [Word32] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Word32 -> Int
forall a. Enum a => a -> Int
fromEnum [Word32]
glyphs

    [(IntSet, Atlas)]
a <- IO [(IntSet, Atlas)] -> m [(IntSet, Atlas)]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [(IntSet, Atlas)] -> m [(IntSet, Atlas)])
-> IO [(IntSet, Atlas)] -> m [(IntSet, Atlas)]
forall a b. (a -> b) -> a -> b
$ STM [(IntSet, Atlas)] -> IO [(IntSet, Atlas)]
forall a. STM a -> IO a
atomically (STM [(IntSet, Atlas)] -> IO [(IntSet, Atlas)])
-> STM [(IntSet, Atlas)] -> IO [(IntSet, Atlas)]
forall a b. (a -> b) -> a -> b
$ TMVar [(IntSet, Atlas)] -> STM [(IntSet, Atlas)]
forall a. TMVar a -> STM a
readTMVar (TMVar [(IntSet, Atlas)] -> STM [(IntSet, Atlas)])
-> TMVar [(IntSet, Atlas)] -> STM [(IntSet, Atlas)]
forall a b. (a -> b) -> a -> b
$ Font -> TMVar [(IntSet, Atlas)]
atlases Font
font
    Atlas
atlas <- case [Atlas
a' | (IntSet
gs, Atlas
a') <- [(IntSet, Atlas)]
a, IntSet
glyphset IntSet -> IntSet -> Bool
`IS.isSubsetOf` IntSet
gs] of
        (Atlas
atlas:[Atlas]
_) -> Atlas -> m Atlas
forall (m :: * -> *) a. Monad m => a -> m a
return Atlas
atlas
        [Atlas]
_ -> TMVar [(IntSet, Atlas)]
-> FT_Face -> IntSet -> (Float, Float) -> m Atlas
forall (m :: * -> *).
(MonadIO m, MonadFail m, MonadError TypograffitiError m) =>
TMVar [(IntSet, Atlas)]
-> FT_Face -> IntSet -> (Float, Float) -> m Atlas
allocAtlas' (Font -> TMVar [(IntSet, Atlas)]
atlases Font
font) (Font -> FT_Face
freetype Font
font) IntSet
glyphset (Font -> (Float, Float)
fontScale Font
font)

    let lh :: Float
lh = if Float
minLineHeight Float -> Float -> Bool
forall a. Eq a => a -> a -> Bool
== Float
0 then Font -> Float
lineHeight Font
font else Float
minLineHeight
    (RichText -> n (AllocatedRendering [TextTransform]))
-> m (RichText -> n (AllocatedRendering [TextTransform]))
forall (m :: * -> *) a. Monad m => a -> m a
return ((RichText -> n (AllocatedRendering [TextTransform]))
 -> m (RichText -> n (AllocatedRendering [TextTransform])))
-> (RichText -> n (AllocatedRendering [TextTransform]))
-> m (RichText -> n (AllocatedRendering [TextTransform]))
forall a b. (a -> b) -> a -> b
$ Int
-> Float
-> (RichText -> n (AllocatedRendering [TextTransform]))
-> RichText
-> n (AllocatedRendering [TextTransform])
forall (m :: * -> *).
(MonadIO m, MonadFail m) =>
Int -> Float -> TextRenderer m -> TextRenderer m
drawLinesWrapper Int
tabwidth Float
lh ((RichText -> n (AllocatedRendering [TextTransform]))
 -> RichText -> n (AllocatedRendering [TextTransform]))
-> (RichText -> n (AllocatedRendering [TextTransform]))
-> RichText
-> n (AllocatedRendering [TextTransform])
forall a b. (a -> b) -> a -> b
$
        \RichText {[Feature]
Text
features :: RichText -> [Feature]
text :: RichText -> Text
features :: [Feature]
text :: Text
..} -> FontStore n
-> Atlas
-> [(GlyphInfo, GlyphPos)]
-> n (AllocatedRendering [TextTransform])
forall (n :: * -> *).
FontStore n
-> Atlas
-> [(GlyphInfo, GlyphPos)]
-> n (AllocatedRendering [TextTransform])
drawGlyphs FontStore n
store Atlas
atlas ([(GlyphInfo, GlyphPos)] -> n (AllocatedRendering [TextTransform]))
-> [(GlyphInfo, GlyphPos)]
-> n (AllocatedRendering [TextTransform])
forall a b. (a -> b) -> a -> b
$
            Font -> Buffer -> [Feature] -> [(GlyphInfo, GlyphPos)]
shape (Font -> Font
harfbuzz Font
font) Buffer
defaultBuffer { text :: Text
HB.text = Text
text } []

-- | Opens & sizes the given font using both FreeType & Harfbuzz,
-- loading it into the `FontStore` before returning.
allocFont :: (MonadIO m, MonadError TypograffitiError m) =>
        FontStore n -> FilePath -> Int -> GlyphSize -> HB.FontOptions -> m Font
allocFont :: forall (m :: * -> *) (n :: * -> *).
(MonadIO m, MonadError TypograffitiError m) =>
FontStore n
-> FilePath -> Int -> GlyphSize -> FontOptions -> m Font
allocFont FontStore {FT_Library
TMVar (Map (FilePath, GlyphSize, Int, FontOptions) Font)
Atlas
-> [(GlyphInfo, GlyphPos)]
-> n (AllocatedRendering [TextTransform])
lib :: FT_Library
drawGlyphs :: Atlas
-> [(GlyphInfo, GlyphPos)]
-> n (AllocatedRendering [TextTransform])
fontMap :: TMVar (Map (FilePath, GlyphSize, Int, FontOptions) Font)
lib :: forall (n :: * -> *). FontStore n -> FT_Library
drawGlyphs :: forall (n :: * -> *).
FontStore n
-> Atlas
-> [(GlyphInfo, GlyphPos)]
-> n (AllocatedRendering [TextTransform])
fontMap :: forall (n :: * -> *).
FontStore n
-> TMVar (Map (FilePath, GlyphSize, Int, FontOptions) Font)
..} FilePath
filepath Int
index GlyphSize
fontsize FontOptions
options = IO Font -> m Font
forall (m :: * -> *) a.
(MonadIO m, MonadError TypograffitiError m) =>
IO a -> m a
liftFreetype (IO Font -> m Font) -> IO Font -> m Font
forall a b. (a -> b) -> a -> b
$ do
    FT_Face
font <- FT_Library -> FilePath -> Int64 -> IO FT_Face
ft_New_Face FT_Library
lib FilePath
filepath (Int64 -> IO FT_Face) -> Int64 -> IO FT_Face
forall a b. (a -> b) -> a -> b
$ Int -> Int64
forall a. Enum a => Int -> a
toEnum Int
index
    case GlyphSize
fontsize of
        PixelSize Int
w Int
h -> FT_Face -> Word32 -> Word32 -> IO ()
ft_Set_Pixel_Sizes FT_Face
font (Int -> Word32
forall a. Enum a => Int -> a
toEnum (Int -> Word32) -> Int -> Word32
forall a b. (a -> b) -> a -> b
$ Int -> Int
x2 Int
w) (Int -> Word32
forall a. Enum a => Int -> a
toEnum (Int -> Word32) -> Int -> Word32
forall a b. (a -> b) -> a -> b
$ Int -> Int
x2 Int
h)
        CharSize Float
w Float
h Int
dpix Int
dpiy -> FT_Face -> Int64 -> Int64 -> Word32 -> Word32 -> IO ()
ft_Set_Char_Size FT_Face
font (Float -> Int64
forall a b. (RealFrac a, Integral b) => a -> b
floor (Float -> Int64) -> Float -> Int64
forall a b. (a -> b) -> a -> b
$ Float
26.6 Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
2 Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
w)
                                                    (Float -> Int64
forall a b. (RealFrac a, Integral b) => a -> b
floor (Float -> Int64) -> Float -> Int64
forall a b. (a -> b) -> a -> b
$ Float
26.6 Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
2 Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
h)
                                                    (Int -> Word32
forall a. Enum a => Int -> a
toEnum Int
dpix) (Int -> Word32
forall a. Enum a => Int -> a
toEnum Int
dpiy)

    ByteString
bytes <- FilePath -> IO ByteString
B.readFile FilePath
filepath
    let font' :: Font
font' = FontOptions -> Face -> Font
HB.createFontWithOptions FontOptions
options (Face -> Font) -> Face -> Font
forall a b. (a -> b) -> a -> b
$ ByteString -> Word -> Face
HB.createFace ByteString
bytes (Word -> Face) -> Word -> Face
forall a b. (a -> b) -> a -> b
$ Int -> Word
forall a. Enum a => Int -> a
toEnum Int
index

    let designCoords :: [Int64]
designCoords = (Float -> Int64) -> [Float] -> [Int64]
forall a b. (a -> b) -> [a] -> [b]
map Float -> Int64
float2fixed ([Float] -> [Int64]) -> [Float] -> [Int64]
forall a b. (a -> b) -> a -> b
$ Font -> [Float]
HB.fontVarCoordsDesign Font
font'
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Int64] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int64]
designCoords) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FT_Face -> [Int64] -> IO ()
ft_Set_Var_Design_Coordinates FT_Face
font [Int64]
designCoords

    FT_FaceRec
font_ <- IO FT_FaceRec -> IO FT_FaceRec
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FT_FaceRec -> IO FT_FaceRec) -> IO FT_FaceRec -> IO FT_FaceRec
forall a b. (a -> b) -> a -> b
$ FT_Face -> IO FT_FaceRec
forall a. Storable a => Ptr a -> IO a
peek FT_Face
font
    FT_Size_Metrics
size <- FT_SizeRec -> FT_Size_Metrics
srMetrics (FT_SizeRec -> FT_Size_Metrics)
-> IO FT_SizeRec -> IO FT_Size_Metrics
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO FT_SizeRec -> IO FT_SizeRec
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Ptr FT_SizeRec -> IO FT_SizeRec
forall a. Storable a => Ptr a -> IO a
peek (Ptr FT_SizeRec -> IO FT_SizeRec)
-> Ptr FT_SizeRec -> IO FT_SizeRec
forall a b. (a -> b) -> a -> b
$ FT_FaceRec -> Ptr FT_SizeRec
frSize FT_FaceRec
font_)
    let lineHeight :: Float
lineHeight = Int64 -> Float
fixed2float (Int64 -> Float) -> Int64 -> Float
forall a b. (a -> b) -> a -> b
$ FT_Size_Metrics -> Int64
smHeight FT_Size_Metrics
size
    let upem :: Float
upem = FT_UShort -> Float
short2float (FT_UShort -> Float) -> FT_UShort -> Float
forall a b. (a -> b) -> a -> b
$ FT_FaceRec -> FT_UShort
frUnits_per_EM FT_FaceRec
font_
    let scale :: (Float, Float)
scale = (FT_UShort -> Float
short2float (FT_Size_Metrics -> FT_UShort
smX_ppem FT_Size_Metrics
size)Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/Float
upemFloat -> Float -> Float
forall a. Fractional a => a -> a -> a
/Float
2, FT_UShort -> Float
short2float (FT_Size_Metrics -> FT_UShort
smY_ppem FT_Size_Metrics
size)Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/Float
upemFloat -> Float -> Float
forall a. Fractional a => a -> a -> a
/Float
2)

    TMVar [(IntSet, Atlas)]
atlases <- IO (TMVar [(IntSet, Atlas)]) -> IO (TMVar [(IntSet, Atlas)])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (TMVar [(IntSet, Atlas)]) -> IO (TMVar [(IntSet, Atlas)]))
-> IO (TMVar [(IntSet, Atlas)]) -> IO (TMVar [(IntSet, Atlas)])
forall a b. (a -> b) -> a -> b
$ STM (TMVar [(IntSet, Atlas)]) -> IO (TMVar [(IntSet, Atlas)])
forall a. STM a -> IO a
atomically (STM (TMVar [(IntSet, Atlas)]) -> IO (TMVar [(IntSet, Atlas)]))
-> STM (TMVar [(IntSet, Atlas)]) -> IO (TMVar [(IntSet, Atlas)])
forall a b. (a -> b) -> a -> b
$ [(IntSet, Atlas)] -> STM (TMVar [(IntSet, Atlas)])
forall a. a -> STM (TMVar a)
newTMVar []
    let ret :: Font
ret = Font
-> FT_Face
-> TMVar [(IntSet, Atlas)]
-> Float
-> (Float, Float)
-> Font
Font Font
font' FT_Face
font TMVar [(IntSet, Atlas)]
atlases Float
lineHeight (Float, Float)
scale

    STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Map (FilePath, GlyphSize, Int, FontOptions) Font
map <- TMVar (Map (FilePath, GlyphSize, Int, FontOptions) Font)
-> STM (Map (FilePath, GlyphSize, Int, FontOptions) Font)
forall a. TMVar a -> STM a
takeTMVar TMVar (Map (FilePath, GlyphSize, Int, FontOptions) Font)
fontMap
        TMVar (Map (FilePath, GlyphSize, Int, FontOptions) Font)
-> Map (FilePath, GlyphSize, Int, FontOptions) Font -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar (Map (FilePath, GlyphSize, Int, FontOptions) Font)
fontMap (Map (FilePath, GlyphSize, Int, FontOptions) Font -> STM ())
-> Map (FilePath, GlyphSize, Int, FontOptions) Font -> STM ()
forall a b. (a -> b) -> a -> b
$ (FilePath, GlyphSize, Int, FontOptions)
-> Font
-> Map (FilePath, GlyphSize, Int, FontOptions) Font
-> Map (FilePath, GlyphSize, Int, FontOptions) Font
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert (FilePath
filepath, GlyphSize
fontsize, Int
index, FontOptions
options) Font
ret Map (FilePath, GlyphSize, Int, FontOptions) Font
map
    Font -> IO Font
forall (m :: * -> *) a. Monad m => a -> m a
return Font
ret
  where
    x2 :: Int -> Int
x2 = (Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
2)
    float2fixed :: Float -> FT_Fixed
    float2fixed :: Float -> Int64
float2fixed = Int -> Int64
forall a. Enum a => Int -> a
toEnum (Int -> Int64) -> (Float -> Int) -> Float -> Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> Int
forall a. Enum a => a -> Int
fromEnum (Float -> Int) -> (Float -> Float) -> Float -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Float -> Float -> Float
forall a. Num a => a -> a -> a
*Float
bits16)
    fixed2float :: FT_Fixed -> Float
    fixed2float :: Int64 -> Float
fixed2float = (Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/Float
bits16) (Float -> Float) -> (Int64 -> Float) -> Int64 -> Float
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Float
forall a. Enum a => Int -> a
toEnum (Int -> Float) -> (Int64 -> Int) -> Int64 -> Float
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Int
forall a. Enum a => a -> Int
fromEnum
    bits16 :: Float
bits16 = Float
2Float -> Float -> Float
forall a. Floating a => a -> a -> a
**Float
16
    short2float :: FT_UShort -> Float
    short2float :: FT_UShort -> Float
short2float = Int -> Float
forall a. Enum a => Int -> a
toEnum (Int -> Float) -> (FT_UShort -> Int) -> FT_UShort -> Float
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FT_UShort -> Int
forall a. Enum a => a -> Int
fromEnum

-- | Allocates a new Atlas for the given font & glyphset,
-- loading it into the atlas cache before returning.
allocAtlas' :: (MonadIO m, MonadFail m, MonadError TypograffitiError m) =>
    TMVar [(IS.IntSet, Atlas)] -> FT_Face -> IS.IntSet -> (Float, Float) -> m Atlas
allocAtlas' :: forall (m :: * -> *).
(MonadIO m, MonadFail m, MonadError TypograffitiError m) =>
TMVar [(IntSet, Atlas)]
-> FT_Face -> IntSet -> (Float, Float) -> m Atlas
allocAtlas' TMVar [(IntSet, Atlas)]
atlases FT_Face
font IntSet
glyphset (Float, Float)
scale = do
    let glyphs :: [Word32]
glyphs = (Int -> Word32) -> [Int] -> [Word32]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Word32
forall a. Enum a => Int -> a
toEnum ([Int] -> [Word32]) -> [Int] -> [Word32]
forall a b. (a -> b) -> a -> b
$ IntSet -> [Int]
IS.toList IntSet
glyphset
    Atlas
atlas <- GlyphRetriever m -> [Word32] -> (Float, Float) -> m Atlas
forall (m :: * -> *).
(MonadIO m, MonadFail m, MonadError TypograffitiError m) =>
GlyphRetriever m -> [Word32] -> (Float, Float) -> m Atlas
allocAtlas (FT_Face -> GlyphRetriever m
forall (m :: * -> *).
(MonadIO m, MonadError TypograffitiError m) =>
FT_Face -> GlyphRetriever m
glyphRetriever FT_Face
font) [Word32]
glyphs (Float, Float)
scale

    IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        [(IntSet, Atlas)]
a <- TMVar [(IntSet, Atlas)] -> STM [(IntSet, Atlas)]
forall a. TMVar a -> STM a
takeTMVar TMVar [(IntSet, Atlas)]
atlases
        TMVar [(IntSet, Atlas)] -> [(IntSet, Atlas)] -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar [(IntSet, Atlas)]
atlases ([(IntSet, Atlas)] -> STM ()) -> [(IntSet, Atlas)] -> STM ()
forall a b. (a -> b) -> a -> b
$ ((IntSet
glyphset, Atlas
atlas)(IntSet, Atlas) -> [(IntSet, Atlas)] -> [(IntSet, Atlas)]
forall a. a -> [a] -> [a]
:[(IntSet, Atlas)]
a)
    Atlas -> m Atlas
forall (m :: * -> *) a. Monad m => a -> m a
return Atlas
atlas

-- | Frees fonts identified by filepath, index, and\/or fontsize.
-- Returns the glyphsets covered by their newly-freed atlases in case
-- callers wish to make an informed reallocation.
freeFonts :: (MonadIO m, MonadError TypograffitiError m) =>
    FontStore n -> Maybe FilePath -> Maybe Int -> Maybe GlyphSize -> m IS.IntSet
freeFonts :: forall (m :: * -> *) (n :: * -> *).
(MonadIO m, MonadError TypograffitiError m) =>
FontStore n
-> Maybe FilePath -> Maybe Int -> Maybe GlyphSize -> m IntSet
freeFonts FontStore n
store Maybe FilePath
filepath Maybe Int
index Maybe GlyphSize
size = do
    let test :: (FilePath, GlyphSize, Int, d) -> Bool
test (FilePath
filepath', GlyphSize
size', Int
index', d
_) = case (Maybe FilePath
filepath, Maybe Int
index, Maybe GlyphSize
size) of
            (Just FilePath
f, Just Int
i, Just GlyphSize
s) -> FilePath
filepath' FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
f Bool -> Bool -> Bool
&& Int
index' Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
i Bool -> Bool -> Bool
&& GlyphSize
size' GlyphSize -> GlyphSize -> Bool
forall a. Eq a => a -> a -> Bool
== GlyphSize
s
            (Maybe FilePath
Nothing,Just Int
i, Just GlyphSize
s) -> Int
index' Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
i Bool -> Bool -> Bool
&& GlyphSize
size' GlyphSize -> GlyphSize -> Bool
forall a. Eq a => a -> a -> Bool
== GlyphSize
s
            (Just FilePath
f, Maybe Int
Nothing,Just GlyphSize
s) -> FilePath
filepath' FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
f Bool -> Bool -> Bool
&& GlyphSize
size' GlyphSize -> GlyphSize -> Bool
forall a. Eq a => a -> a -> Bool
== GlyphSize
s
            (Maybe FilePath
Nothing,Maybe Int
Nothing,Just GlyphSize
s) -> GlyphSize
size' GlyphSize -> GlyphSize -> Bool
forall a. Eq a => a -> a -> Bool
== GlyphSize
s
            (Just FilePath
f, Just Int
i, Maybe GlyphSize
Nothing)-> FilePath
filepath' FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
f Bool -> Bool -> Bool
&& Int
index' Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
i
            (Maybe FilePath
Nothing,Just Int
i, Maybe GlyphSize
Nothing)-> Int
index' Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
i
            (Just FilePath
f, Maybe Int
Nothing,Maybe GlyphSize
Nothing)-> FilePath
filepath' FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
f
            (Maybe FilePath
Nothing,Maybe Int
Nothing,Maybe GlyphSize
Nothing)-> Bool
True
    Map (FilePath, GlyphSize, Int, FontOptions) Font
fonts <- IO (Map (FilePath, GlyphSize, Int, FontOptions) Font)
-> m (Map (FilePath, GlyphSize, Int, FontOptions) Font)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Map (FilePath, GlyphSize, Int, FontOptions) Font)
 -> m (Map (FilePath, GlyphSize, Int, FontOptions) Font))
-> IO (Map (FilePath, GlyphSize, Int, FontOptions) Font)
-> m (Map (FilePath, GlyphSize, Int, FontOptions) Font)
forall a b. (a -> b) -> a -> b
$ STM (Map (FilePath, GlyphSize, Int, FontOptions) Font)
-> IO (Map (FilePath, GlyphSize, Int, FontOptions) Font)
forall a. STM a -> IO a
atomically (STM (Map (FilePath, GlyphSize, Int, FontOptions) Font)
 -> IO (Map (FilePath, GlyphSize, Int, FontOptions) Font))
-> STM (Map (FilePath, GlyphSize, Int, FontOptions) Font)
-> IO (Map (FilePath, GlyphSize, Int, FontOptions) Font)
forall a b. (a -> b) -> a -> b
$ do
        Map (FilePath, GlyphSize, Int, FontOptions) Font
fonts <- TMVar (Map (FilePath, GlyphSize, Int, FontOptions) Font)
-> STM (Map (FilePath, GlyphSize, Int, FontOptions) Font)
forall a. TMVar a -> STM a
readTMVar (TMVar (Map (FilePath, GlyphSize, Int, FontOptions) Font)
 -> STM (Map (FilePath, GlyphSize, Int, FontOptions) Font))
-> TMVar (Map (FilePath, GlyphSize, Int, FontOptions) Font)
-> STM (Map (FilePath, GlyphSize, Int, FontOptions) Font)
forall a b. (a -> b) -> a -> b
$ FontStore n
-> TMVar (Map (FilePath, GlyphSize, Int, FontOptions) Font)
forall (n :: * -> *).
FontStore n
-> TMVar (Map (FilePath, GlyphSize, Int, FontOptions) Font)
fontMap FontStore n
store
        TMVar (Map (FilePath, GlyphSize, Int, FontOptions) Font)
-> Map (FilePath, GlyphSize, Int, FontOptions) Font -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar (FontStore n
-> TMVar (Map (FilePath, GlyphSize, Int, FontOptions) Font)
forall (n :: * -> *).
FontStore n
-> TMVar (Map (FilePath, GlyphSize, Int, FontOptions) Font)
fontMap FontStore n
store) (Map (FilePath, GlyphSize, Int, FontOptions) Font -> STM ())
-> Map (FilePath, GlyphSize, Int, FontOptions) Font -> STM ()
forall a b. (a -> b) -> a -> b
$ ((FilePath, GlyphSize, Int, FontOptions) -> Font -> Bool)
-> Map (FilePath, GlyphSize, Int, FontOptions) Font
-> Map (FilePath, GlyphSize, Int, FontOptions) Font
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
M.filterWithKey (\(FilePath, GlyphSize, Int, FontOptions)
k Font
_ -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (FilePath, GlyphSize, Int, FontOptions) -> Bool
forall {d}. (FilePath, GlyphSize, Int, d) -> Bool
test (FilePath, GlyphSize, Int, FontOptions)
k) Map (FilePath, GlyphSize, Int, FontOptions) Font
fonts
        Map (FilePath, GlyphSize, Int, FontOptions) Font
-> STM (Map (FilePath, GlyphSize, Int, FontOptions) Font)
forall (m :: * -> *) a. Monad m => a -> m a
return Map (FilePath, GlyphSize, Int, FontOptions) Font
fonts

    [IntSet]
glyphsets <- [Font] -> (Font -> m IntSet) -> m [IntSet]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Font
v | ((FilePath, GlyphSize, Int, FontOptions)
k, Font
v) <- Map (FilePath, GlyphSize, Int, FontOptions) Font
-> [((FilePath, GlyphSize, Int, FontOptions), Font)]
forall k a. Map k a -> [(k, a)]
M.toList Map (FilePath, GlyphSize, Int, FontOptions) Font
fonts, (FilePath, GlyphSize, Int, FontOptions) -> Bool
forall {d}. (FilePath, GlyphSize, Int, d) -> Bool
test (FilePath, GlyphSize, Int, FontOptions)
k] ((Font -> m IntSet) -> m [IntSet])
-> (Font -> m IntSet) -> m [IntSet]
forall a b. (a -> b) -> a -> b
$ \Font
font -> do
        IO () -> m ()
forall (m :: * -> *) a.
(MonadIO m, MonadError TypograffitiError m) =>
IO a -> m a
liftFreetype (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ FT_Face -> IO ()
ft_Done_Face (FT_Face -> IO ()) -> FT_Face -> IO ()
forall a b. (a -> b) -> a -> b
$ Font -> FT_Face
freetype Font
font
        -- Harfbuzz font auto-frees.
        [(IntSet, Atlas)]
atlases' <- IO [(IntSet, Atlas)] -> m [(IntSet, Atlas)]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [(IntSet, Atlas)] -> m [(IntSet, Atlas)])
-> IO [(IntSet, Atlas)] -> m [(IntSet, Atlas)]
forall a b. (a -> b) -> a -> b
$ STM [(IntSet, Atlas)] -> IO [(IntSet, Atlas)]
forall a. STM a -> IO a
atomically (STM [(IntSet, Atlas)] -> IO [(IntSet, Atlas)])
-> STM [(IntSet, Atlas)] -> IO [(IntSet, Atlas)]
forall a b. (a -> b) -> a -> b
$ TMVar [(IntSet, Atlas)] -> STM [(IntSet, Atlas)]
forall a. TMVar a -> STM a
readTMVar (TMVar [(IntSet, Atlas)] -> STM [(IntSet, Atlas)])
-> TMVar [(IntSet, Atlas)] -> STM [(IntSet, Atlas)]
forall a b. (a -> b) -> a -> b
$ Font -> TMVar [(IntSet, Atlas)]
atlases Font
font
        [IntSet]
glyphsets <- [(IntSet, Atlas)] -> ((IntSet, Atlas) -> m IntSet) -> m [IntSet]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(IntSet, Atlas)]
atlases' (((IntSet, Atlas) -> m IntSet) -> m [IntSet])
-> ((IntSet, Atlas) -> m IntSet) -> m [IntSet]
forall a b. (a -> b) -> a -> b
$ \(IntSet
glyphset, Atlas
atlas) -> do
            Atlas -> m ()
forall (m :: * -> *). MonadIO m => Atlas -> m ()
freeAtlas Atlas
atlas
            IntSet -> m IntSet
forall (m :: * -> *) a. Monad m => a -> m a
return IntSet
glyphset
        IntSet -> m IntSet
forall (m :: * -> *) a. Monad m => a -> m a
return (IntSet -> m IntSet) -> IntSet -> m IntSet
forall a b. (a -> b) -> a -> b
$ [IntSet] -> IntSet
forall (f :: * -> *). Foldable f => f IntSet -> IntSet
IS.unions [IntSet]
glyphsets
    IntSet -> m IntSet
forall (m :: * -> *) a. Monad m => a -> m a
return (IntSet -> m IntSet) -> IntSet -> m IntSet
forall a b. (a -> b) -> a -> b
$ [IntSet] -> IntSet
forall (f :: * -> *). Foldable f => f IntSet -> IntSet
IS.unions [IntSet]
glyphsets

-- | Runs the given callback with a new `FontStore`.
-- Due to FreeType limitations this font store should not persist outside the callback.
withFontStore :: (MonadIO n, MonadError TypograffitiError n, MonadFail n) =>
    (FontStore n -> ExceptT TypograffitiError IO a) ->
    IO (Either TypograffitiError a)
withFontStore :: forall (n :: * -> *) a.
(MonadIO n, MonadError TypograffitiError n, MonadFail n) =>
(FontStore n -> ExceptT TypograffitiError IO a)
-> IO (Either TypograffitiError a)
withFontStore FontStore n -> ExceptT TypograffitiError IO a
cb = (FT_Library -> IO (Either TypograffitiError a))
-> IO (Either TypograffitiError a)
forall a. (FT_Library -> IO a) -> IO a
ft_With_FreeType ((FT_Library -> IO (Either TypograffitiError a))
 -> IO (Either TypograffitiError a))
-> (FT_Library -> IO (Either TypograffitiError a))
-> IO (Either TypograffitiError a)
forall a b. (a -> b) -> a -> b
$ \FT_Library
lib -> ExceptT TypograffitiError IO a -> IO (Either TypograffitiError a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT TypograffitiError IO a -> IO (Either TypograffitiError a))
-> ExceptT TypograffitiError IO a
-> IO (Either TypograffitiError a)
forall a b. (a -> b) -> a -> b
$ do
    FontStore n
store <- FT_Library -> ExceptT TypograffitiError IO (FontStore n)
forall (m :: * -> *) (n :: * -> *).
(MonadIO m, MonadError TypograffitiError m, MonadIO n,
 MonadError TypograffitiError n, MonadFail n) =>
FT_Library -> m (FontStore n)
newFontStore FT_Library
lib
    a
ret <- FontStore n -> ExceptT TypograffitiError IO a
cb FontStore n
store
    FontStore n
-> Maybe FilePath
-> Maybe Int
-> Maybe GlyphSize
-> ExceptT TypograffitiError IO IntSet
forall (m :: * -> *) (n :: * -> *).
(MonadIO m, MonadError TypograffitiError m) =>
FontStore n
-> Maybe FilePath -> Maybe Int -> Maybe GlyphSize -> m IntSet
freeFonts FontStore n
store Maybe FilePath
forall a. Maybe a
Nothing Maybe Int
forall a. Maybe a
Nothing Maybe GlyphSize
forall a. Maybe a
Nothing
    a -> ExceptT TypograffitiError IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
ret

-- | Allocates a new FontStore wrapping given FreeType state.
newFontStore :: (MonadIO m, MonadError TypograffitiError m,
    MonadIO n, MonadError TypograffitiError n, MonadFail n) => FT_Library -> m (FontStore n)
newFontStore :: forall (m :: * -> *) (n :: * -> *).
(MonadIO m, MonadError TypograffitiError m, MonadIO n,
 MonadError TypograffitiError n, MonadFail n) =>
FT_Library -> m (FontStore n)
newFontStore FT_Library
lib = do
    Atlas
-> [(GlyphInfo, GlyphPos)]
-> n (AllocatedRendering [TextTransform])
drawGlyphs <- m (Atlas
   -> [(GlyphInfo, GlyphPos)]
   -> n (AllocatedRendering [TextTransform]))
forall (m :: * -> *) (n :: * -> *).
(MonadIO m, MonadError TypograffitiError m, MonadIO n, MonadFail n,
 MonadError TypograffitiError n) =>
m (Atlas
   -> [(GlyphInfo, GlyphPos)]
   -> n (AllocatedRendering [TextTransform]))
makeDrawGlyphs
    TMVar (Map (FilePath, GlyphSize, Int, FontOptions) Font)
store <- IO (TMVar (Map (FilePath, GlyphSize, Int, FontOptions) Font))
-> m (TMVar (Map (FilePath, GlyphSize, Int, FontOptions) Font))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (TMVar (Map (FilePath, GlyphSize, Int, FontOptions) Font))
 -> m (TMVar (Map (FilePath, GlyphSize, Int, FontOptions) Font)))
-> IO (TMVar (Map (FilePath, GlyphSize, Int, FontOptions) Font))
-> m (TMVar (Map (FilePath, GlyphSize, Int, FontOptions) Font))
forall a b. (a -> b) -> a -> b
$ STM (TMVar (Map (FilePath, GlyphSize, Int, FontOptions) Font))
-> IO (TMVar (Map (FilePath, GlyphSize, Int, FontOptions) Font))
forall a. STM a -> IO a
atomically (STM (TMVar (Map (FilePath, GlyphSize, Int, FontOptions) Font))
 -> IO (TMVar (Map (FilePath, GlyphSize, Int, FontOptions) Font)))
-> STM (TMVar (Map (FilePath, GlyphSize, Int, FontOptions) Font))
-> IO (TMVar (Map (FilePath, GlyphSize, Int, FontOptions) Font))
forall a b. (a -> b) -> a -> b
$ Map (FilePath, GlyphSize, Int, FontOptions) Font
-> STM (TMVar (Map (FilePath, GlyphSize, Int, FontOptions) Font))
forall a. a -> STM (TMVar a)
newTMVar Map (FilePath, GlyphSize, Int, FontOptions) Font
forall k a. Map k a
M.empty

    FontStore n -> m (FontStore n)
forall (m :: * -> *) a. Monad m => a -> m a
return (FontStore n -> m (FontStore n)) -> FontStore n -> m (FontStore n)
forall a b. (a -> b) -> a -> b
$ TMVar (Map (FilePath, GlyphSize, Int, FontOptions) Font)
-> (Atlas
    -> [(GlyphInfo, GlyphPos)]
    -> n (AllocatedRendering [TextTransform]))
-> FT_Library
-> FontStore n
forall (n :: * -> *).
TMVar (Map (FilePath, GlyphSize, Int, FontOptions) Font)
-> (Atlas
    -> [(GlyphInfo, GlyphPos)]
    -> n (AllocatedRendering [TextTransform]))
-> FT_Library
-> FontStore n
FontStore TMVar (Map (FilePath, GlyphSize, Int, FontOptions) Font)
store Atlas
-> [(GlyphInfo, GlyphPos)]
-> n (AllocatedRendering [TextTransform])
drawGlyphs FT_Library
lib