{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-}
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(..))
data FontStore n = FontStore {
forall (n :: * -> *).
FontStore n
-> TMVar (Map (FilePath, GlyphSize, Int, FontOptions) Font)
fontMap :: TMVar (Map (FilePath, GlyphSize, Int, FontOptions) Font),
forall (n :: * -> *).
FontStore n
-> Atlas
-> [(GlyphInfo, GlyphPos)]
-> n (AllocatedRendering [TextTransform])
drawGlyphs :: Atlas -> [(GlyphInfo, GlyphPos)] -> n (AllocatedRendering [TextTransform]),
forall (n :: * -> *). FontStore n -> FT_Library
lib :: FT_Library
}
data Font = Font {
Font -> Font
harfbuzz :: HB.Font,
Font -> FT_Face
freetype :: FT_Face,
Font -> TMVar [(IntSet, Atlas)]
atlases :: TMVar [(IS.IntSet, Atlas)],
Font -> Float
lineHeight :: Float,
Font -> (Float, Float)
fontScale :: (Float, Float)
}
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 } []
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
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
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
[(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
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
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