-- NOTE: Not tested
module FreeType.FontConfig (ftCharIndex, ftCharSet, ftCharSetAndSpacing,
    ftQuery, ftQueryAll, ftQueryFace,
    FTFC_Instance(..), FTFC_Metrics(..), FTFC_Subpixel(..), instantiatePattern,
    FTFC_Glyph(..), glyphForIndex, bmpAndMetricsForIndex) where

import Graphics.Text.Font.Choose.CharSet (CharSet, CharSet_, thawCharSet, thawCharSet_)
import Graphics.Text.Font.Choose.Pattern (Pattern, Pattern_, thawPattern, thawPattern_)
import Graphics.Text.Font.Choose.FontSet (FontSet, FontSet_, withFontSet, thawFontSet)
import FreeType.Core.Base (FT_Face(..))
import Data.Word (Word32, Word)

import Foreign.Ptr (nullPtr, Ptr)
import Foreign.Storable (Storable(..))
import Foreign.Marshal.Alloc (alloca)
import Foreign.C.String (CString, withCString)
import System.IO.Unsafe (unsafePerformIO)

import Control.Exception (throw, catch)
import Graphics.Text.Font.Choose.Result (Error(ErrTypeMismatch))

-- For FcFt transliteration
import Graphics.Text.Font.Choose.Value (Value(..))
import Graphics.Text.Font.Choose.Pattern (getValue', getValue0, getValue, getValues')

import Data.Maybe (fromMaybe)
import Linear.V2 (V2(..))
import Linear.Matrix(M22)
import Data.Bits ((.|.))

import FreeType.Core.Base
import FreeType.Support.Outline (ft_Outline_Embolden)
import FreeType.Control.Subpixel (FT_LcdFilter, ft_Library_SetLcdFilter)
import FreeType.Core.Types
import FreeType.Exception (FtError(..))

c2w :: Char -> Word32
c2w :: Char -> Word32
c2w = Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word32) -> (Char -> Int) -> Char -> Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
forall a. Enum a => a -> Int
fromEnum

-- | Maps a Unicode char to a glyph index.
-- This function uses information from several possible underlying encoding
-- tables to work around broken fonts. As a result, this function isn't designed
-- to be used in performance sensitive areas; results from this function are
-- intended to be cached by higher level functions.
ftCharIndex :: FT_Face -> Char -> Word
ftCharIndex :: FT_Face -> Char -> Word
ftCharIndex face :: FT_Face
face = FT_Face -> Word32 -> Word
fcFreeTypeCharIndex FT_Face
face (Word32 -> Word) -> (Char -> Word32) -> Char -> Word
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Word32
c2w
foreign import ccall "FcFreeTypeCharIndex" fcFreeTypeCharIndex :: FT_Face -> Word32 -> Word

-- | Scans a FreeType face and returns the set of encoded Unicode chars.
ftCharSet :: FT_Face -> CharSet
ftCharSet :: FT_Face -> CharSet
ftCharSet face :: FT_Face
face = IO CharSet -> CharSet
forall a. IO a -> a
unsafePerformIO (IO CharSet -> CharSet) -> IO CharSet -> CharSet
forall a b. (a -> b) -> a -> b
$ IO CharSet_ -> IO CharSet
thawCharSet_ (IO CharSet_ -> IO CharSet) -> IO CharSet_ -> IO CharSet
forall a b. (a -> b) -> a -> b
$ FT_Face -> Ptr () -> IO CharSet_
fcFreeTypeCharSet FT_Face
face Ptr ()
forall a. Ptr a
nullPtr
foreign import ccall "FcFreeTypeCharSet" fcFreeTypeCharSet
    :: FT_Face -> Ptr () -> IO CharSet_ -- 2nd arg's deprecated!

-- | How consistant are the widths of the chars in a font.
data Spacing = Proportional -- ^ Where the font has glyphs of many widths.
    | Dual -- ^ Where the font has glyphs in precisely two widths.
    | Mono -- ^ Where all glyphs have the same width.
-- | Scans a FreeType face and returns the set of encoded Unicode chars.
-- `snd` receives the computed spacing type of the font.
ftCharSetAndSpacing :: FT_Face -> (CharSet, Spacing)
ftCharSetAndSpacing :: FT_Face -> (CharSet, Spacing)
ftCharSetAndSpacing face :: FT_Face
face = IO (CharSet, Spacing) -> (CharSet, Spacing)
forall a. IO a -> a
unsafePerformIO (IO (CharSet, Spacing) -> (CharSet, Spacing))
-> IO (CharSet, Spacing) -> (CharSet, Spacing)
forall a b. (a -> b) -> a -> b
$ (Ptr Int -> IO (CharSet, Spacing)) -> IO (CharSet, Spacing)
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr Int -> IO (CharSet, Spacing)) -> IO (CharSet, Spacing))
-> (Ptr Int -> IO (CharSet, Spacing)) -> IO (CharSet, Spacing)
forall a b. (a -> b) -> a -> b
$ \spacing' :: Ptr Int
spacing' -> do
    CharSet
chars <- IO CharSet_ -> IO CharSet
thawCharSet_ (IO CharSet_ -> IO CharSet) -> IO CharSet_ -> IO CharSet
forall a b. (a -> b) -> a -> b
$ FT_Face -> Ptr () -> Ptr Int -> IO CharSet_
fcFreeTypeCharSetAndSpacing FT_Face
face Ptr ()
forall a. Ptr a
nullPtr Ptr Int
spacing'
    Int
spacing_ <- Ptr Int -> IO Int
forall a. Storable a => Ptr a -> IO a
peek Ptr Int
spacing'
    let spacing :: Spacing
spacing = case Int
spacing_ of{
        0 -> Spacing
Proportional;
        90 -> Spacing
Dual;
        100 -> Spacing
Mono;
        _ -> Error -> Spacing
forall a e. Exception e => e -> a
throw Error
ErrTypeMismatch}
    (CharSet, Spacing) -> IO (CharSet, Spacing)
forall (m :: * -> *) a. Monad m => a -> m a
return (CharSet
chars, Spacing
spacing)
foreign import ccall "FcFreeTypeCharSetAndSpacing" fcFreeTypeCharSetAndSpacing ::
    FT_Face -> Ptr () -> Ptr Int -> IO CharSet_ -- 2nd arg's deprecated!

-- | Constructs a pattern representing the 'id'th face in 'fst'.
-- The number of faces in 'file' is returned in 'snd'.
ftQuery :: FilePath -> Int -> IO (Pattern, Int)
ftQuery :: FilePath -> Int -> IO (Pattern, Int)
ftQuery filename :: FilePath
filename id :: Int
id = FilePath -> (CString -> IO (Pattern, Int)) -> IO (Pattern, Int)
forall a. FilePath -> (CString -> IO a) -> IO a
withCString FilePath
filename ((CString -> IO (Pattern, Int)) -> IO (Pattern, Int))
-> (CString -> IO (Pattern, Int)) -> IO (Pattern, Int)
forall a b. (a -> b) -> a -> b
$ \filename' :: CString
filename' -> (Ptr Int -> IO (Pattern, Int)) -> IO (Pattern, Int)
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr Int -> IO (Pattern, Int)) -> IO (Pattern, Int))
-> (Ptr Int -> IO (Pattern, Int)) -> IO (Pattern, Int)
forall a b. (a -> b) -> a -> b
$ \count' :: Ptr Int
count' -> do
    Pattern
pattern <- IO (Ptr Pattern') -> IO Pattern
thawPattern_ (IO (Ptr Pattern') -> IO Pattern)
-> IO (Ptr Pattern') -> IO Pattern
forall a b. (a -> b) -> a -> b
$ CString -> Int -> Ptr () -> Ptr Int -> IO (Ptr Pattern')
fcFreeTypeQuery CString
filename' Int
id Ptr ()
forall a. Ptr a
nullPtr Ptr Int
count'
    Int
count <- Ptr Int -> IO Int
forall a. Storable a => Ptr a -> IO a
peek Ptr Int
count'
    (Pattern, Int) -> IO (Pattern, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Pattern
pattern, Int
count)
foreign import ccall "FcFreeTypeQuery" fcFreeTypeQuery ::
    CString -> Int -> Ptr () -> Ptr Int -> IO Pattern_ -- 3rd arg's deprecated!

-- | Constructs patterns found in 'filename'.
-- If id is -1, then all patterns found in 'filename' are added to 'fst'.
-- Otherwise, this function works exactly like `ftQuery`.
-- The number of faces in 'filename' is returned in 'snd'.
ftQueryAll :: FilePath -> Int -> IO (FontSet, Int)
ftQueryAll :: FilePath -> Int -> IO (FontSet, Int)
ftQueryAll filename :: FilePath
filename id :: Int
id = FilePath -> (CString -> IO (FontSet, Int)) -> IO (FontSet, Int)
forall a. FilePath -> (CString -> IO a) -> IO a
withCString FilePath
filename ((CString -> IO (FontSet, Int)) -> IO (FontSet, Int))
-> (CString -> IO (FontSet, Int)) -> IO (FontSet, Int)
forall a b. (a -> b) -> a -> b
$ \filename' :: CString
filename' -> (Ptr Int -> IO (FontSet, Int)) -> IO (FontSet, Int)
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr Int -> IO (FontSet, Int)) -> IO (FontSet, Int))
-> (Ptr Int -> IO (FontSet, Int)) -> IO (FontSet, Int)
forall a b. (a -> b) -> a -> b
$ \count' :: Ptr Int
count' ->
    FontSet -> (FontSet_ -> IO (FontSet, Int)) -> IO (FontSet, Int)
forall a. FontSet -> (FontSet_ -> IO a) -> IO a
withFontSet [] ((FontSet_ -> IO (FontSet, Int)) -> IO (FontSet, Int))
-> (FontSet_ -> IO (FontSet, Int)) -> IO (FontSet, Int)
forall a b. (a -> b) -> a -> b
$ \fonts' :: FontSet_
fonts' -> do
        CString -> Int -> Ptr () -> Ptr Int -> FontSet_ -> IO Word
fcFreeTypeQueryAll CString
filename' Int
id Ptr ()
forall a. Ptr a
nullPtr Ptr Int
count' FontSet_
fonts'
        FontSet
fonts <- FontSet_ -> IO FontSet
thawFontSet FontSet_
fonts'
        Int
count <- Ptr Int -> IO Int
forall a. Storable a => Ptr a -> IO a
peek Ptr Int
count'
        (FontSet, Int) -> IO (FontSet, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (FontSet
fonts, Int
count)
foreign import ccall "FcFreeTypeQueryAll" fcFreeTypeQueryAll ::
    CString -> Int -> Ptr () -> Ptr Int -> FontSet_ -> IO Word -- 2nd arg's deprecated!

-- | Constructs a pattern representing 'face'.
-- 'filename' and 'id' are used solely as data for pattern elements.
ftQueryFace :: FT_Face -> FilePath -> Int -> IO Pattern
ftQueryFace :: FT_Face -> FilePath -> Int -> IO Pattern
ftQueryFace face :: FT_Face
face filename :: FilePath
filename id :: Int
id = FilePath -> (CString -> IO Pattern) -> IO Pattern
forall a. FilePath -> (CString -> IO a) -> IO a
withCString FilePath
filename ((CString -> IO Pattern) -> IO Pattern)
-> (CString -> IO Pattern) -> IO Pattern
forall a b. (a -> b) -> a -> b
$ \filename' :: CString
filename' ->
    IO (Ptr Pattern') -> IO Pattern
thawPattern_ (IO (Ptr Pattern') -> IO Pattern)
-> IO (Ptr Pattern') -> IO Pattern
forall a b. (a -> b) -> a -> b
$ FT_Face -> CString -> Int -> Ptr () -> IO (Ptr Pattern')
fcFreeTypeQueryFace FT_Face
face CString
filename' Int
id Ptr ()
forall a. Ptr a
nullPtr
foreign import ccall "FcFreeTypeQueryFace" fcFreeTypeQueryFace ::
    FT_Face -> CString -> Int -> Ptr () -> IO Pattern_ -- Final arg's deprecated!

------
--- Transliterated from FcFt
--- https://codeberg.org/dnkl/fcft/
--- Untested
------

-- | A `FT_Face` queried from FontConfig with glyph-loading parameters.
data FTFC_Instance = Instance {
    FTFC_Instance -> Maybe FilePath
fontName :: Maybe String,
    FTFC_Instance -> Maybe FilePath
fontPath :: Maybe String,
    FTFC_Instance -> FT_Face
fontFace :: FT_Face,
    FTFC_Instance -> Int
fontLoadFlags :: Int,
    FTFC_Instance -> Bool
fontAntialias :: Bool,
    FTFC_Instance -> Bool
fontEmbolden :: Bool,
    FTFC_Instance -> Bool
fontIsColor :: Bool,
    FTFC_Instance -> Int
fontRenderFlags :: Int,
    FTFC_Instance -> Int
fontRenderFlagsSubpixel :: Int,
    FTFC_Instance -> Double
fontPixelSizeFixup :: Double,
    FTFC_Instance -> Bool
fontPixelFixupEstimated :: Bool,
    FTFC_Instance -> Bool
fontBGR :: Bool,
    FTFC_Instance -> Word32
fontLCDFilter :: FT_LcdFilter,
    FTFC_Instance -> [FilePath]
fontFeats :: [String], -- Callers probably want to validate via harfbuzz
    FTFC_Instance -> FTFC_Metrics
fontMetrics :: FTFC_Metrics
}
-- | Results queried from FontConfig with caller-relevant properties,
-- notably relating to layout.
data FTFC_Metrics = Metrics {
    FTFC_Metrics -> Int
height :: Int,
    FTFC_Metrics -> Int
descent :: Int,
    FTFC_Metrics -> Int
ascent :: Int,
    FTFC_Metrics -> (Int, Int)
maxAdvance :: (Int, Int), -- Width/height of font's widest glyph.
    FTFC_Metrics -> Bool
metricsAntialias :: Bool,
    FTFC_Metrics -> FTFC_Subpixel
metricsSubpixel :: FTFC_Subpixel,
    FTFC_Metrics -> Maybe FilePath
metricsName :: Maybe String
}
-- | Defines subpixel order to use.
-- Note that this is *ignored* if antialiasing has been disabled.
data FTFC_Subpixel = SubpixelNone -- ^ From FontConfig.
    | SubpixelHorizontalRGB | SubpixelHorizontalBGR |
    SubpixelVerticalRGB | SubpixelVerticalBGR
    | SubpixelDefault -- ^ Disable subpixel antialiasing.

-- | Converts the results of a FontConfig query requesting a specific size
-- into a `FT_Face` & related properties.
-- Throw exceptions.
instantiatePattern :: FT_Library -> Pattern -> (Double, Double) -> IO FTFC_Instance
instantiatePattern :: FT_Library -> Pattern -> (Double, Double) -> IO FTFC_Instance
instantiatePattern ftlib :: FT_Library
ftlib pattern :: Pattern
pattern (req_pt_size :: Double
req_pt_size, req_px_size :: Double
req_px_size) = do
    let dpi :: Double
dpi = Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe 75 (Maybe Double -> Double) -> Maybe Double -> Double
forall a b. (a -> b) -> a -> b
$ FilePath -> Pattern -> Maybe Double
forall x. ToValue x => FilePath -> Pattern -> Maybe x
getValue' "dpi" Pattern
pattern :: Double

    FT_Face
ft_face <- case FilePath -> Pattern -> Value
getValue "ftface" Pattern
pattern of
        ValueFTFace x :: FT_Face
x -> FT_Face -> IO FT_Face
forall (m :: * -> *) a. Monad m => a -> m a
return FT_Face
x
        _ -> FT_Library -> FilePath -> FT_Long -> IO FT_Face
ft_New_Face FT_Library
ftlib (FilePath -> Pattern -> FilePath
forall x. ToValue x => FilePath -> Pattern -> x
getValue0 "file" Pattern
pattern) -- is a mutex needed?
            (Int -> FT_Long
forall a. Enum a => Int -> a
toEnum (Int -> FT_Long) -> Int -> FT_Long
forall a b. (a -> b) -> a -> b
$ Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe 0 (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ FilePath -> Pattern -> Maybe Int
forall x. ToValue x => FilePath -> Pattern -> Maybe x
getValue' "index" Pattern
pattern)

    FT_Face -> Word32 -> Word32 -> IO ()
ft_Set_Pixel_Sizes FT_Face
ft_face 0 (Word32 -> IO ()) -> Word32 -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> Word32
forall a. Enum a => Int -> a
toEnum (Int -> Word32) -> Int -> Word32
forall a b. (a -> b) -> a -> b
$ Double -> Int
forall a. Enum a => a -> Int
fromEnum (Double -> Int) -> Double -> Int
forall a b. (a -> b) -> a -> b
$
        Double -> Maybe Double -> Double
forall a. a -> Maybe a -> a
fromMaybe Double
req_px_size (Maybe Double -> Double) -> Maybe Double -> Double
forall a b. (a -> b) -> a -> b
$ FilePath -> Pattern -> Maybe Double
forall x. ToValue x => FilePath -> Pattern -> Maybe x
getValue' "pixelsize" Pattern
pattern
    let scalable :: Bool
scalable = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
True (Maybe Bool -> Bool) -> Maybe Bool -> Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> Pattern -> Maybe Bool
forall x. ToValue x => FilePath -> Pattern -> Maybe x
getValue' "scalable" Pattern
pattern
    let outline :: Bool
outline = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
True (Maybe Bool -> Bool) -> Maybe Bool -> Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> Pattern -> Maybe Bool
forall x. ToValue x => FilePath -> Pattern -> Maybe x
getValue' "outline" Pattern
pattern
    (pixel_fixup :: Double
pixel_fixup, fixup_estimated :: Bool
fixup_estimated) <- case FilePath -> Pattern -> Value
getValue "pixelsizefixupfactor" Pattern
pattern of
        ValueDouble x :: Double
x -> (Double, Bool) -> IO (Double, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Double
x, Bool
False)
        _ | Bool
scalable Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
outline -> do
            let px_size :: Double
px_size = if Double
req_px_size Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< 0 then Double
req_pt_size Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
dpi Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ 72 else Double
req_px_size
            FT_FaceRec
ft_face' <- FT_Face -> IO FT_FaceRec
forall a. Storable a => Ptr a -> IO a
peek FT_Face
ft_face
            FT_SizeRec
size' <- 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
ft_face'
            (Double, Bool) -> IO (Double, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Double
px_size Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ (FT_UShort -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (FT_UShort -> Double) -> FT_UShort -> Double
forall a b. (a -> b) -> a -> b
$ FT_Size_Metrics -> FT_UShort
smY_ppem (FT_Size_Metrics -> FT_UShort) -> FT_Size_Metrics -> FT_UShort
forall a b. (a -> b) -> a -> b
$ FT_SizeRec -> FT_Size_Metrics
srMetrics FT_SizeRec
size'), Bool
True)
        _ -> (Double, Bool) -> IO (Double, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (1, Bool
False)

    let hinting :: Bool
hinting = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
True (Maybe Bool -> Bool) -> Maybe Bool -> Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> Pattern -> Maybe Bool
forall x. ToValue x => FilePath -> Pattern -> Maybe x
getValue' "hinting" Pattern
pattern
    let antialias :: Bool
antialias = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
True (Maybe Bool -> Bool) -> Maybe Bool -> Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> Pattern -> Maybe Bool
forall x. ToValue x => FilePath -> Pattern -> Maybe x
getValue' "antialias" Pattern
pattern
    let hintstyle :: Int
hintstyle = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe 1 (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ FilePath -> Pattern -> Maybe Int
forall x. ToValue x => FilePath -> Pattern -> Maybe x
getValue' "hintstyle" Pattern
pattern :: Int
    let rgba :: Int
rgba = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe 0 (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ FilePath -> Pattern -> Maybe Int
forall x. ToValue x => FilePath -> Pattern -> Maybe x
getValue' "rgba" Pattern
pattern :: Int
    let load_flags :: Int
load_flags | Bool -> Bool
not Bool
antialias Bool -> Bool -> Bool
&& (Bool -> Bool
not Bool
hinting Bool -> Bool -> Bool
|| Int
hintstyle Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0) =
                        Int
ft_LOAD_NO_HINTING Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. Int
ft_LOAD_MONOCHROME
                   | Bool -> Bool
not Bool
antialias = Int
ft_LOAD_MONOCHROME
                   | Bool -> Bool
not Bool
hinting Bool -> Bool -> Bool
|| Int
hintstyle Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 = Int
ft_LOAD_NO_HINTING
                   | Bool
otherwise = Int
ft_LOAD_DEFAULT
    let load_target :: Int
load_target | Bool -> Bool
not Bool
antialias Bool -> Bool -> Bool
&& Bool
hinting Bool -> Bool -> Bool
&& Int
hintstyle Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= 0 = Int
ft_LOAD_TARGET_MONO
                    | Bool -> Bool
not Bool
antialias = Int
ft_LOAD_TARGET_NORMAL
                    | Bool -> Bool
not Bool
hinting Bool -> Bool -> Bool
|| Int
hintstyle Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 = Int
ft_LOAD_TARGET_NORMAL
                    | Int
hintstyle Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 1 = Int
ft_LOAD_TARGET_LIGHT
                    | Int
hintstyle Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 2 = Int
ft_LOAD_TARGET_NORMAL
                    | Int
rgba Int -> [Int] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [1, 2] = Int
ft_LOAD_TARGET_LCD
                    | Int
rgba Int -> [Int] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [3, 4] = Int
ft_LOAD_TARGET_LCD_V
                    | Bool
otherwise = Int
ft_LOAD_TARGET_NORMAL

    let embedded_bitmap :: Bool
embedded_bitmap = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
True (Maybe Bool -> Bool) -> Maybe Bool -> Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> Pattern -> Maybe Bool
forall x. ToValue x => FilePath -> Pattern -> Maybe x
getValue' "embeddedbitmap" Pattern
pattern
    let load_flags1 :: Int
load_flags1 | Bool
embedded_bitmap = Int
load_flags Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. Int
ft_LOAD_NO_BITMAP
                    | Bool
otherwise = Int
load_flags
    let autohint :: Bool
autohint = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False (Maybe Bool -> Bool) -> Maybe Bool -> Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> Pattern -> Maybe Bool
forall x. ToValue x => FilePath -> Pattern -> Maybe x
getValue' "autohint" Pattern
pattern
    let load_flags2 :: Int
load_flags2 | Bool
autohint = Int
load_flags Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. Int
ft_LOAD_FORCE_AUTOHINT
                    | Bool
otherwise = Int
load_flags
    let render_flags_normal :: Int
render_flags_normal | Bool -> Bool
not Bool
antialias = Int
ft_RENDER_MODE_MONO
                            | Bool
otherwise = Int
ft_RENDER_MODE_NORMAL
    let render_flags_subpixel :: Int
render_flags_subpixel | Bool -> Bool
not Bool
antialias = Int
ft_RENDER_MODE_MONO
                              | Int
rgba Int -> [Int] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [1, 2] = Int
ft_RENDER_MODE_LCD
                              | Int
rgba Int -> [Int] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [3, 4] = Int
ft_RENDER_MODE_LCD_V
                              | Bool
otherwise = Int
ft_RENDER_MODE_NORMAL

    let lcdfilter :: Int
lcdfilter = case Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe 1 (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ FilePath -> Pattern -> Maybe Int
forall x. ToValue x => FilePath -> Pattern -> Maybe x
getValue' "lcdfilter" Pattern
pattern :: Int of {
        3 -> 16; x :: Int
x -> Int
x}
    case FilePath -> Pattern -> Value
getValue "matrix" Pattern
pattern of
        ValueMatrix m :: M22 Double
m -> FT_Face -> Maybe FT_Matrix -> Maybe FT_Vector -> IO ()
ft_Set_Transform FT_Face
ft_face (FT_Matrix -> Maybe FT_Matrix
forall a. a -> Maybe a
Just (FT_Matrix -> Maybe FT_Matrix) -> FT_Matrix -> Maybe FT_Matrix
forall a b. (a -> b) -> a -> b
$ M22 Double -> FT_Matrix
m22toFt M22 Double
m) Maybe FT_Vector
forall a. Maybe a
Nothing
        _ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    FT_FaceRec
ft_face' <- FT_Face -> IO FT_FaceRec
forall a. Storable a => Ptr a -> IO a
peek FT_Face
ft_face
    FT_SizeRec
size' <- 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
ft_face'
    let metrics' :: FT_Size_Metrics
metrics' = FT_SizeRec -> FT_Size_Metrics
srMetrics FT_SizeRec
size'
    let c :: a -> Double
c x :: a
x = a -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
x Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ 64 Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
pixel_fixup
    FTFC_Instance -> IO FTFC_Instance
forall (m :: * -> *) a. Monad m => a -> m a
return Instance :: Maybe FilePath
-> Maybe FilePath
-> FT_Face
-> Int
-> Bool
-> Bool
-> Bool
-> Int
-> Int
-> Double
-> Bool
-> Bool
-> Word32
-> [FilePath]
-> FTFC_Metrics
-> FTFC_Instance
Instance {
        fontName :: Maybe FilePath
fontName = FilePath -> Pattern -> Maybe FilePath
forall x. ToValue x => FilePath -> Pattern -> Maybe x
getValue' "fullname" Pattern
pattern,
        fontPath :: Maybe FilePath
fontPath = FilePath -> Pattern -> Maybe FilePath
forall x. ToValue x => FilePath -> Pattern -> Maybe x
getValue' "file" Pattern
pattern,
        fontFace :: FT_Face
fontFace = FT_Face
ft_face,
        fontLoadFlags :: Int
fontLoadFlags = Int
load_target Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. Int
load_flags Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. Int
ft_LOAD_COLOR,
        fontAntialias :: Bool
fontAntialias = Bool
antialias,
        fontEmbolden :: Bool
fontEmbolden = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False (Maybe Bool -> Bool) -> Maybe Bool -> Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> Pattern -> Maybe Bool
forall x. ToValue x => FilePath -> Pattern -> Maybe x
getValue' "embolden" Pattern
pattern,
        fontIsColor :: Bool
fontIsColor = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False (Maybe Bool -> Bool) -> Maybe Bool -> Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> Pattern -> Maybe Bool
forall x. ToValue x => FilePath -> Pattern -> Maybe x
getValue' "color" Pattern
pattern,
        fontRenderFlags :: Int
fontRenderFlags = Int
render_flags_normal,
        fontRenderFlagsSubpixel :: Int
fontRenderFlagsSubpixel = Int
render_flags_subpixel,
        fontPixelSizeFixup :: Double
fontPixelSizeFixup = Double
pixel_fixup,
        fontPixelFixupEstimated :: Bool
fontPixelFixupEstimated = Bool
fixup_estimated,
        fontBGR :: Bool
fontBGR = Int
rgba Int -> [Int] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [2, 4],
        fontLCDFilter :: Word32
fontLCDFilter = Int -> Word32
forall a. Enum a => Int -> a
toEnum Int
lcdfilter,
        fontFeats :: [FilePath]
fontFeats = FilePath -> Pattern -> [FilePath]
forall b. ToValue b => FilePath -> Pattern -> [b]
getValues' "fontfeatures" Pattern
pattern,
        fontMetrics :: FTFC_Metrics
fontMetrics = Metrics :: Int
-> Int
-> Int
-> (Int, Int)
-> Bool
-> FTFC_Subpixel
-> Maybe FilePath
-> FTFC_Metrics
Metrics {
            height :: Int
height = Double -> Int
forall a. Enum a => a -> Int
fromEnum (Double -> Int) -> Double -> Int
forall a b. (a -> b) -> a -> b
$ FT_Long -> Double
forall a. Integral a => a -> Double
c (FT_Long -> Double) -> FT_Long -> Double
forall a b. (a -> b) -> a -> b
$ FT_Size_Metrics -> FT_Long
smHeight FT_Size_Metrics
metrics',
            descent :: Int
descent = Double -> Int
forall a. Enum a => a -> Int
fromEnum (Double -> Int) -> Double -> Int
forall a b. (a -> b) -> a -> b
$ FT_Long -> Double
forall a. Integral a => a -> Double
c (FT_Long -> Double) -> FT_Long -> Double
forall a b. (a -> b) -> a -> b
$ FT_Size_Metrics -> FT_Long
smDescender FT_Size_Metrics
metrics',
            ascent :: Int
ascent = Double -> Int
forall a. Enum a => a -> Int
fromEnum (Double -> Int) -> Double -> Int
forall a b. (a -> b) -> a -> b
$ FT_Long -> Double
forall a. Integral a => a -> Double
c (FT_Long -> Double) -> FT_Long -> Double
forall a b. (a -> b) -> a -> b
$ FT_Size_Metrics -> FT_Long
smAscender FT_Size_Metrics
metrics',
            maxAdvance :: (Int, Int)
maxAdvance = (Double -> Int
forall a. Enum a => a -> Int
fromEnum (Double -> Int) -> Double -> Int
forall a b. (a -> b) -> a -> b
$ FT_Long -> Double
forall a. Integral a => a -> Double
c (FT_Long -> Double) -> FT_Long -> Double
forall a b. (a -> b) -> a -> b
$ FT_Size_Metrics -> FT_Long
smMax_advance FT_Size_Metrics
metrics',
                Double -> Int
forall a. Enum a => a -> Int
fromEnum (Double -> Int) -> Double -> Int
forall a b. (a -> b) -> a -> b
$ FT_Long -> Double
forall a. Integral a => a -> Double
c (FT_Long -> Double) -> FT_Long -> Double
forall a b. (a -> b) -> a -> b
$ FT_Size_Metrics -> FT_Long
smHeight FT_Size_Metrics
metrics'),
            metricsAntialias :: Bool
metricsAntialias = Bool
antialias,
            metricsSubpixel :: FTFC_Subpixel
metricsSubpixel = case Int
rgba of
                _ | Bool -> Bool
not Bool
antialias -> FTFC_Subpixel
SubpixelNone
                1 -> FTFC_Subpixel
SubpixelHorizontalRGB
                2 -> FTFC_Subpixel
SubpixelHorizontalBGR
                3 -> FTFC_Subpixel
SubpixelVerticalRGB
                4 -> FTFC_Subpixel
SubpixelVerticalBGR
                _ -> FTFC_Subpixel
SubpixelNone,
            metricsName :: Maybe FilePath
metricsName = FilePath -> Pattern -> Maybe FilePath
forall x. ToValue x => FilePath -> Pattern -> Maybe x
getValue' "fullname" Pattern
pattern
        }
      }

-- | Results from `glyphForIndex`.
data FTFC_Glyph a = Glyph {
    FTFC_Glyph a -> Maybe FilePath
glyphFontName :: Maybe String,
    FTFC_Glyph a -> a
glyphImage :: a,
    FTFC_Glyph a -> (Double, Double)
glyphAdvance :: (Double, Double),
    FTFC_Glyph a -> FTFC_Subpixel
glyphSubpixel :: FTFC_Subpixel,
    FTFC_Glyph a -> FT_Glyph_Metrics
glyphMetrics :: FT_Glyph_Metrics
}

-- | Looks up a given glyph in a `FTFC_Instance` & its underlying `FT_Face`
-- Taking into account additional properties from FontConfig.
-- Runs a provided callback to render the glyph into a reusable datastructure.
-- The `FT_Bitmap` given to this callback must not be used outside it.
-- Throws exceptions.
glyphForIndex :: FTFC_Instance -> Word32 -> FTFC_Subpixel -> 
    (FT_Bitmap -> IO a) -> IO (FTFC_Glyph a)
glyphForIndex :: FTFC_Instance
-> Word32
-> FTFC_Subpixel
-> (FT_Bitmap -> IO a)
-> IO (FTFC_Glyph a)
glyphForIndex font :: FTFC_Instance
font index :: Word32
index subpixel :: FTFC_Subpixel
subpixel cb :: FT_Bitmap -> IO a
cb = do
    FT_Face -> Word32 -> FT_Int32 -> IO ()
ft_Load_Glyph (FTFC_Instance -> FT_Face
fontFace FTFC_Instance
font) Word32
index (Int -> FT_Int32
forall a. Enum a => Int -> a
toEnum (Int -> FT_Int32) -> Int -> FT_Int32
forall a b. (a -> b) -> a -> b
$ FTFC_Instance -> Int
fontLoadFlags FTFC_Instance
font)
    FT_FaceRec
face' <- FT_Face -> IO FT_FaceRec
forall a. Storable a => Ptr a -> IO a
peek (FT_Face -> IO FT_FaceRec) -> FT_Face -> IO FT_FaceRec
forall a b. (a -> b) -> a -> b
$ FTFC_Instance -> FT_Face
fontFace FTFC_Instance
font
    FT_SizeRec
size' <- 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
face'
    -- Formula from old FreeType function `FT_GlyphSlotEmbolden`.
    -- Approximate as fallback for fonts not using fontsets or variables axis.
    let strength :: FT_Long
strength = FT_UShort -> FT_Long
forall a b. (Integral a, Num b) => a -> b
fromIntegral (FT_FaceRec -> FT_UShort
frUnits_per_EM FT_FaceRec
face')FT_Long -> FT_Long -> FT_Long
forall a. Num a => a -> a -> a
*FT_Size_Metrics -> FT_Long
smY_scale (FT_SizeRec -> FT_Size_Metrics
srMetrics FT_SizeRec
size')FT_Long -> FT_Long -> FT_Long
forall a. Integral a => a -> a -> a
`div`24
    FT_GlyphSlotRec
glyph' <- Ptr FT_GlyphSlotRec -> IO FT_GlyphSlotRec
forall a. Storable a => Ptr a -> IO a
peek (Ptr FT_GlyphSlotRec -> IO FT_GlyphSlotRec)
-> Ptr FT_GlyphSlotRec -> IO FT_GlyphSlotRec
forall a b. (a -> b) -> a -> b
$ FT_FaceRec -> Ptr FT_GlyphSlotRec
frGlyph FT_FaceRec
face'

    FT_GlyphSlotRec
glyph1' <- case FT_GlyphSlotRec -> Word32
gsrFormat FT_GlyphSlotRec
glyph' of
        FT_GLYPH_FORMAT_OUTLINE | FTFC_Instance -> Bool
fontEmbolden FTFC_Instance
font -> do
            FT_Outline
outline <- FT_Outline -> (Ptr FT_Outline -> IO ()) -> IO FT_Outline
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO a
withPtr (FT_GlyphSlotRec -> FT_Outline
gsrOutline FT_GlyphSlotRec
glyph') ((Ptr FT_Outline -> IO ()) -> IO FT_Outline)
-> (Ptr FT_Outline -> IO ()) -> IO FT_Outline
forall a b. (a -> b) -> a -> b
$ (Ptr FT_Outline -> FT_Long -> IO ())
-> FT_Long -> Ptr FT_Outline -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Ptr FT_Outline -> FT_Long -> IO ()
ft_Outline_Embolden FT_Long
strength
            FT_GlyphSlotRec -> IO FT_GlyphSlotRec
forall (m :: * -> *) a. Monad m => a -> m a
return FT_GlyphSlotRec
glyph' { gsrOutline :: FT_Outline
gsrOutline = FT_Outline
outline }
        _ -> FT_GlyphSlotRec -> IO FT_GlyphSlotRec
forall (m :: * -> *) a. Monad m => a -> m a
return FT_GlyphSlotRec
glyph'

    let render_flags :: Int
render_flags = case FTFC_Subpixel
subpixel of {
-- FT_GLYPH_FORMAT_SVG is not exposed by our language bindings,
-- Should be largely irrelevant now... Certain FreeType versions required this flag.
--        _ | FT_GLYPH_FORMAT_SVG <- gsrFormat glyph1' -> ft_RENDER_MODE_NORMAL;
        _ | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ FTFC_Instance -> Bool
fontAntialias FTFC_Instance
font -> FTFC_Instance -> Int
fontRenderFlags FTFC_Instance
font;
        SubpixelNone -> FTFC_Instance -> Int
fontRenderFlags FTFC_Instance
font;
        SubpixelHorizontalRGB -> Int
ft_RENDER_MODE_LCD;
        SubpixelHorizontalBGR -> Int
ft_RENDER_MODE_LCD;
        SubpixelVerticalRGB -> Int
ft_RENDER_MODE_LCD_V;
        SubpixelVerticalBGR -> Int
ft_RENDER_MODE_LCD_V;
        SubpixelDefault -> FTFC_Instance -> Int
fontRenderFlagsSubpixel FTFC_Instance
font}
    let bgr :: Bool
bgr = case FTFC_Subpixel
subpixel of {
        _ | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ FTFC_Instance -> Bool
fontAntialias FTFC_Instance
font -> Bool
False;
        SubpixelNone -> Bool
False;
        SubpixelHorizontalRGB -> Bool
False;
        SubpixelHorizontalBGR -> Bool
True;
        SubpixelVerticalRGB -> Bool
False;
        SubpixelVerticalBGR -> Bool
True;
        SubpixelDefault -> FTFC_Instance -> Bool
fontBGR FTFC_Instance
font}

    Bool
can_set_lcd_filter <- IO () -> IO Bool
forall a. IO a -> IO Bool
isSuccess (IO () -> IO Bool) -> IO () -> IO Bool
forall a b. (a -> b) -> a -> b
$ FT_Library -> Word32 -> IO ()
ft_Library_SetLcdFilter (FT_GlyphSlotRec -> FT_Library
gsrLibrary FT_GlyphSlotRec
glyph1') 0
    -- FIXME: Do we need a mutex?
    let set_lcd_filter :: IO ()
set_lcd_filter = FT_Library -> Word32 -> IO ()
ft_Library_SetLcdFilter (FT_GlyphSlotRec -> FT_Library
gsrLibrary FT_GlyphSlotRec
glyph1') (Word32 -> IO ()) -> Word32 -> IO ()
forall a b. (a -> b) -> a -> b
$ FTFC_Instance -> Word32
fontLCDFilter FTFC_Instance
font
    case Int
render_flags of {
        FT_RENDER_MODE_LCD | Bool
can_set_lcd_filter -> IO ()
set_lcd_filter;
        FT_RENDER_MODE_LCD_V | Bool
can_set_lcd_filter -> IO ()
set_lcd_filter;
        _ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()}

    FT_GlyphSlotRec
glyph2' <- case FT_GlyphSlotRec -> Word32
gsrFormat FT_GlyphSlotRec
glyph1' of {
        FT_GLYPH_FORMAT_BITMAP -> FT_GlyphSlotRec -> IO FT_GlyphSlotRec
forall (m :: * -> *) a. Monad m => a -> m a
return FT_GlyphSlotRec
glyph1';
        _ -> FT_GlyphSlotRec
-> (Ptr FT_GlyphSlotRec -> IO ()) -> IO FT_GlyphSlotRec
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO a
withPtr FT_GlyphSlotRec
glyph1' ((Ptr FT_GlyphSlotRec -> IO ()) -> IO FT_GlyphSlotRec)
-> (Ptr FT_GlyphSlotRec -> IO ()) -> IO FT_GlyphSlotRec
forall a b. (a -> b) -> a -> b
$ (Ptr FT_GlyphSlotRec -> Word32 -> IO ())
-> Word32 -> Ptr FT_GlyphSlotRec -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Ptr FT_GlyphSlotRec -> Word32 -> IO ()
ft_Render_Glyph (Word32 -> Ptr FT_GlyphSlotRec -> IO ())
-> Word32 -> Ptr FT_GlyphSlotRec -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> Word32
forall a. Enum a => Int -> a
toEnum Int
render_flags}
    -- If set_lcd_filter requires mutex, release it here.
    case FT_GlyphSlotRec -> Word32
gsrFormat FT_GlyphSlotRec
glyph2' of {
        FT_GLYPH_FORMAT_BITMAP -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ();
        _ -> FtError -> IO ()
forall a e. Exception e => e -> a
throw (FtError -> IO ()) -> FtError -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FT_Int32 -> FtError
FtError "glyphForIndex" 2
    }

    a
img <- FT_Bitmap -> IO a
cb (FT_Bitmap -> IO a) -> FT_Bitmap -> IO a
forall a b. (a -> b) -> a -> b
$ FT_GlyphSlotRec -> FT_Bitmap
gsrBitmap FT_GlyphSlotRec
glyph2'
    FTFC_Glyph a -> IO (FTFC_Glyph a)
forall (m :: * -> *) a. Monad m => a -> m a
return Glyph :: forall a.
Maybe FilePath
-> a
-> (Double, Double)
-> FTFC_Subpixel
-> FT_Glyph_Metrics
-> FTFC_Glyph a
Glyph {
        glyphFontName :: Maybe FilePath
glyphFontName = FTFC_Instance -> Maybe FilePath
fontName FTFC_Instance
font, glyphImage :: a
glyphImage = a
img,
        glyphAdvance :: (Double, Double)
glyphAdvance = (FT_Long -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (FT_Vector -> FT_Long
vX (FT_Vector -> FT_Long) -> FT_Vector -> FT_Long
forall a b. (a -> b) -> a -> b
$ FT_GlyphSlotRec -> FT_Vector
gsrAdvance FT_GlyphSlotRec
glyph2') Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ 64 Double -> Double -> Double
forall a. Num a => a -> a -> a
*
            if FTFC_Instance -> Bool
fontPixelFixupEstimated FTFC_Instance
font then FTFC_Instance -> Double
fontPixelSizeFixup FTFC_Instance
font else 1,
            FT_Long -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (FT_Vector -> FT_Long
vY (FT_Vector -> FT_Long) -> FT_Vector -> FT_Long
forall a b. (a -> b) -> a -> b
$ FT_GlyphSlotRec -> FT_Vector
gsrAdvance FT_GlyphSlotRec
glyph2') Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ 64 Double -> Double -> Double
forall a. Num a => a -> a -> a
*
            if FTFC_Instance -> Bool
fontPixelFixupEstimated FTFC_Instance
font then FTFC_Instance -> Double
fontPixelSizeFixup FTFC_Instance
font else 1),
        glyphSubpixel :: FTFC_Subpixel
glyphSubpixel = FTFC_Subpixel
subpixel,
        glyphMetrics :: FT_Glyph_Metrics
glyphMetrics = FT_GlyphSlotRec -> FT_Glyph_Metrics
gsrMetrics FT_GlyphSlotRec
glyph2'
    }

bmpAndMetricsForIndex ::
    FTFC_Instance -> FTFC_Subpixel -> Word32 -> IO (FT_Bitmap, FT_Glyph_Metrics)
bmpAndMetricsForIndex :: FTFC_Instance
-> FTFC_Subpixel -> Word32 -> IO (FT_Bitmap, FT_Glyph_Metrics)
bmpAndMetricsForIndex inst :: FTFC_Instance
inst subpixel :: FTFC_Subpixel
subpixel index :: Word32
index = do
    FTFC_Glyph FT_Bitmap
glyph <- FTFC_Instance
-> Word32
-> FTFC_Subpixel
-> (FT_Bitmap -> IO FT_Bitmap)
-> IO (FTFC_Glyph FT_Bitmap)
forall a.
FTFC_Instance
-> Word32
-> FTFC_Subpixel
-> (FT_Bitmap -> IO a)
-> IO (FTFC_Glyph a)
glyphForIndex FTFC_Instance
inst Word32
index FTFC_Subpixel
subpixel FT_Bitmap -> IO FT_Bitmap
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    (FT_Bitmap, FT_Glyph_Metrics) -> IO (FT_Bitmap, FT_Glyph_Metrics)
forall (m :: * -> *) a. Monad m => a -> m a
return (FTFC_Glyph FT_Bitmap -> FT_Bitmap
forall a. FTFC_Glyph a -> a
glyphImage FTFC_Glyph FT_Bitmap
glyph, FTFC_Glyph FT_Bitmap -> FT_Glyph_Metrics
forall a. FTFC_Glyph a -> FT_Glyph_Metrics
glyphMetrics FTFC_Glyph FT_Bitmap
glyph)

withPtr :: Storable a => a -> (Ptr a -> IO b) -> IO a
withPtr :: a -> (Ptr a -> IO b) -> IO a
withPtr a :: a
a cb :: Ptr a -> IO b
cb = (Ptr a -> IO a) -> IO a
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr a -> IO a) -> IO a) -> (Ptr a -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \a' :: Ptr a
a' -> do
    Ptr a -> a -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr a
a' a
a
    Ptr a -> IO b
cb Ptr a
a'
    Ptr a -> IO a
forall a. Storable a => Ptr a -> IO a
peek Ptr a
a'

isSuccess :: IO a -> IO Bool
isSuccess :: IO a -> IO Bool
isSuccess cb :: IO a
cb = do
    IO a
cb
    Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
  IO Bool -> (FtError -> IO Bool) -> IO Bool
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(FtError _ _) -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

m22toFt :: M22 Double -> FT_Matrix
m22toFt :: M22 Double -> FT_Matrix
m22toFt (V2 (V2 xx :: Double
xx xy :: Double
xy) (V2 yx :: Double
yx yy :: Double
yy)) = FT_Matrix :: FT_Long -> FT_Long -> FT_Long -> FT_Long -> FT_Matrix
FT_Matrix {
    mXx :: FT_Long
mXx = Double -> FT_Long
c Double
xx FT_Long -> FT_Long -> FT_Long
forall a. Num a => a -> a -> a
* 0x10000, mXy :: FT_Long
mXy = Double -> FT_Long
c Double
xy FT_Long -> FT_Long -> FT_Long
forall a. Num a => a -> a -> a
* 0x10000,
    mYx :: FT_Long
mYx = Double -> FT_Long
c Double
yx FT_Long -> FT_Long -> FT_Long
forall a. Num a => a -> a -> a
* 0x10000, mYy :: FT_Long
mYy = Double -> FT_Long
c Double
yy FT_Long -> FT_Long -> FT_Long
forall a. Num a => a -> a -> a
* 0x10000
  } where c :: Double -> FT_Long
c = Int -> FT_Long
forall a. Enum a => Int -> a
toEnum (Int -> FT_Long) -> (Double -> Int) -> Double -> FT_Long
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Int
forall a. Enum a => a -> Int
fromEnum

-- Taken from FreeType language bindings,
-- but converted to constants rather than pattern synonyms.
ft_LOAD_DEFAULT, ft_LOAD_NO_SCALE, ft_LOAD_NO_HINTING, ft_LOAD_RENDER,
    ft_LOAD_NO_BITMAP, ft_LOAD_VERTICAL_LAYOUT, ft_LOAD_FORCE_AUTOHINT,
    ft_LOAD_CROP_BITMAP, ft_LOAD_PEDANTIC, ft_LOAD_IGNORE_GLOBAL_ADVANCE_WIDTH,
    ft_LOAD_NO_RECURSE, ft_LOAD_IGNORE_TRANSFORM, ft_LOAD_MONOCHROME,
    ft_LOAD_LINEAR_DESIGN, ft_LOAD_NO_AUTOHINT, ft_LOAD_COLOR,
    ft_LOAD_COMPUTE_METRICS, ft_LOAD_BITMAP_METRICS_ONLY :: Int
ft_LOAD_DEFAULT :: Int
ft_LOAD_DEFAULT                     = 0
ft_LOAD_NO_SCALE :: Int
ft_LOAD_NO_SCALE                    = 1
ft_LOAD_NO_HINTING :: Int
ft_LOAD_NO_HINTING                  = 2
ft_LOAD_RENDER :: Int
ft_LOAD_RENDER                      = 4
ft_LOAD_NO_BITMAP :: Int
ft_LOAD_NO_BITMAP                   = 8
ft_LOAD_VERTICAL_LAYOUT :: Int
ft_LOAD_VERTICAL_LAYOUT             = 16
ft_LOAD_FORCE_AUTOHINT :: Int
ft_LOAD_FORCE_AUTOHINT              = 32
ft_LOAD_CROP_BITMAP :: Int
ft_LOAD_CROP_BITMAP                 = 64
ft_LOAD_PEDANTIC :: Int
ft_LOAD_PEDANTIC                    = 128
ft_LOAD_IGNORE_GLOBAL_ADVANCE_WIDTH :: Int
ft_LOAD_IGNORE_GLOBAL_ADVANCE_WIDTH = 512
ft_LOAD_NO_RECURSE :: Int
ft_LOAD_NO_RECURSE                  = 1024
ft_LOAD_IGNORE_TRANSFORM :: Int
ft_LOAD_IGNORE_TRANSFORM            = 2048
ft_LOAD_MONOCHROME :: Int
ft_LOAD_MONOCHROME                  = 4096
ft_LOAD_LINEAR_DESIGN :: Int
ft_LOAD_LINEAR_DESIGN               = 8192
ft_LOAD_NO_AUTOHINT :: Int
ft_LOAD_NO_AUTOHINT                 = 32768
ft_LOAD_COLOR :: Int
ft_LOAD_COLOR                       = 1048576
ft_LOAD_COMPUTE_METRICS :: Int
ft_LOAD_COMPUTE_METRICS             = 2097152
ft_LOAD_BITMAP_METRICS_ONLY :: Int
ft_LOAD_BITMAP_METRICS_ONLY         = 4194304

ft_LOAD_TARGET_NORMAL, ft_LOAD_TARGET_LIGHT, ft_LOAD_TARGET_MONO,
    ft_LOAD_TARGET_LCD, ft_LOAD_TARGET_LCD_V :: Int
ft_LOAD_TARGET_NORMAL :: Int
ft_LOAD_TARGET_NORMAL = 0
ft_LOAD_TARGET_LIGHT :: Int
ft_LOAD_TARGET_LIGHT  = 65536
ft_LOAD_TARGET_MONO :: Int
ft_LOAD_TARGET_MONO   = 131072
ft_LOAD_TARGET_LCD :: Int
ft_LOAD_TARGET_LCD    = 196608
ft_LOAD_TARGET_LCD_V :: Int
ft_LOAD_TARGET_LCD_V  = 262144

ft_RENDER_MODE_NORMAL, ft_RENDER_MODE_LIGHT, ft_RENDER_MODE_MONO,
    ft_RENDER_MODE_LCD, ft_RENDER_MODE_LCD_V :: Int
ft_RENDER_MODE_NORMAL :: Int
ft_RENDER_MODE_NORMAL = 0
ft_RENDER_MODE_LIGHT :: Int
ft_RENDER_MODE_LIGHT  = 1
ft_RENDER_MODE_MONO :: Int
ft_RENDER_MODE_MONO   = 2
ft_RENDER_MODE_LCD :: Int
ft_RENDER_MODE_LCD    = 3
ft_RENDER_MODE_LCD_V :: Int
ft_RENDER_MODE_LCD_V  = 4