-- 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 -> FT_UInt
c2w = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 FT_Face
face = FT_Face -> FT_UInt -> Word
fcFreeTypeCharIndex FT_Face
face forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> FT_UInt
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 FT_Face
face = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ IO CharSet_ -> IO CharSet
thawCharSet_ forall a b. (a -> b) -> a -> b
$ FT_Face -> Ptr () -> IO CharSet_
fcFreeTypeCharSet FT_Face
face 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 FT_Face
face = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca forall a b. (a -> b) -> a -> b
$ \Ptr Int
spacing' -> do
    CharSet
chars <- IO CharSet_ -> IO CharSet
thawCharSet_ forall a b. (a -> b) -> a -> b
$ FT_Face -> Ptr () -> Ptr Int -> IO CharSet_
fcFreeTypeCharSetAndSpacing FT_Face
face forall a. Ptr a
nullPtr Ptr Int
spacing'
    Int
spacing_ <- forall a. Storable a => Ptr a -> IO a
peek Ptr Int
spacing'
    let spacing :: Spacing
spacing = case Int
spacing_ of{
        Int
0 -> Spacing
Proportional;
        Int
90 -> Spacing
Dual;
        Int
100 -> Spacing
Mono;
        Int
_ -> forall a e. Exception e => e -> a
throw Error
ErrTypeMismatch}
    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 FilePath
filename Int
id = forall a. FilePath -> (CString -> IO a) -> IO a
withCString FilePath
filename forall a b. (a -> b) -> a -> b
$ \CString
filename' -> forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca forall a b. (a -> b) -> a -> b
$ \Ptr Int
count' -> do
    Pattern
pattern <- IO (Ptr Pattern') -> IO Pattern
thawPattern_ forall a b. (a -> b) -> a -> b
$ CString -> Int -> Ptr () -> Ptr Int -> IO (Ptr Pattern')
fcFreeTypeQuery CString
filename' Int
id forall a. Ptr a
nullPtr Ptr Int
count'
    Int
count <- forall a. Storable a => Ptr a -> IO a
peek Ptr Int
count'
    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 FilePath
filename Int
id = forall a. FilePath -> (CString -> IO a) -> IO a
withCString FilePath
filename forall a b. (a -> b) -> a -> b
$ \CString
filename' -> forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca forall a b. (a -> b) -> a -> b
$ \Ptr Int
count' ->
    forall a. FontSet -> (FontSet_ -> IO a) -> IO a
withFontSet [] forall a b. (a -> b) -> a -> b
$ \FontSet_
fonts' -> do
        CString -> Int -> Ptr () -> Ptr Int -> FontSet_ -> IO Word
fcFreeTypeQueryAll CString
filename' Int
id forall a. Ptr a
nullPtr Ptr Int
count' FontSet_
fonts'
        FontSet
fonts <- FontSet_ -> IO FontSet
thawFontSet FontSet_
fonts'
        Int
count <- forall a. Storable a => Ptr a -> IO a
peek Ptr Int
count'
        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 FT_Face
face FilePath
filename Int
id = forall a. FilePath -> (CString -> IO a) -> IO a
withCString FilePath
filename forall a b. (a -> b) -> a -> b
$ \CString
filename' ->
    IO (Ptr Pattern') -> IO Pattern
thawPattern_ forall a b. (a -> b) -> a -> b
$ FT_Face -> CString -> Int -> Ptr () -> IO (Ptr Pattern')
fcFreeTypeQueryFace FT_Face
face CString
filename' Int
id 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 -> FT_UInt
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 FT_Library
ftlib Pattern
pattern (Double
req_pt_size, Double
req_px_size) = do
    let dpi :: Double
dpi = forall a. a -> Maybe a -> a
fromMaybe Double
75 forall a b. (a -> b) -> a -> b
$ forall x. ToValue x => FilePath -> Pattern -> Maybe x
getValue' FilePath
"dpi" Pattern
pattern :: Double

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

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

    let hinting :: Bool
hinting = forall a. a -> Maybe a -> a
fromMaybe Bool
True forall a b. (a -> b) -> a -> b
$ forall x. ToValue x => FilePath -> Pattern -> Maybe x
getValue' FilePath
"hinting" Pattern
pattern
    let antialias :: Bool
antialias = forall a. a -> Maybe a -> a
fromMaybe Bool
True forall a b. (a -> b) -> a -> b
$ forall x. ToValue x => FilePath -> Pattern -> Maybe x
getValue' FilePath
"antialias" Pattern
pattern
    let hintstyle :: Int
hintstyle = forall a. a -> Maybe a -> a
fromMaybe Int
1 forall a b. (a -> b) -> a -> b
$ forall x. ToValue x => FilePath -> Pattern -> Maybe x
getValue' FilePath
"hintstyle" Pattern
pattern :: Int
    let rgba :: Int
rgba = forall a. a -> Maybe a -> a
fromMaybe Int
0 forall a b. (a -> b) -> a -> b
$ forall x. ToValue x => FilePath -> Pattern -> Maybe x
getValue' FilePath
"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 forall a. Eq a => a -> a -> Bool
== Int
0) =
                        Int
ft_LOAD_NO_HINTING 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 forall a. Eq a => a -> a -> Bool
== Int
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 forall a. Eq a => a -> a -> Bool
/= Int
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 forall a. Eq a => a -> a -> Bool
== Int
0 = Int
ft_LOAD_TARGET_NORMAL
                    | Int
hintstyle forall a. Eq a => a -> a -> Bool
== Int
1 = Int
ft_LOAD_TARGET_LIGHT
                    | Int
hintstyle forall a. Eq a => a -> a -> Bool
== Int
2 = Int
ft_LOAD_TARGET_NORMAL
                    | Int
rgba forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int
1, Int
2] = Int
ft_LOAD_TARGET_LCD
                    | Int
rgba forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int
3, Int
4] = Int
ft_LOAD_TARGET_LCD_V
                    | Bool
otherwise = Int
ft_LOAD_TARGET_NORMAL

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

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

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

-- | Results from `glyphForIndex`.
data FTFC_Glyph a = Glyph {
    forall a. FTFC_Glyph a -> Maybe FilePath
glyphFontName :: Maybe String,
    forall a. FTFC_Glyph a -> a
glyphImage :: a,
    forall a. FTFC_Glyph a -> (Double, Double)
glyphAdvance :: (Double, Double),
    forall a. FTFC_Glyph a -> FTFC_Subpixel
glyphSubpixel :: FTFC_Subpixel,
    forall a. 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 :: forall a.
FTFC_Instance
-> FT_UInt
-> FTFC_Subpixel
-> (FT_Bitmap -> IO a)
-> IO (FTFC_Glyph a)
glyphForIndex FTFC_Instance
font FT_UInt
index FTFC_Subpixel
subpixel FT_Bitmap -> IO a
cb = do
    FT_Face -> FT_UInt -> FT_Int32 -> IO ()
ft_Load_Glyph (FTFC_Instance -> FT_Face
fontFace FTFC_Instance
font) FT_UInt
index (forall a. Enum a => Int -> a
toEnum forall a b. (a -> b) -> a -> b
$ FTFC_Instance -> Int
fontLoadFlags FTFC_Instance
font)
    FT_FaceRec
face' <- forall a. Storable a => Ptr a -> IO a
peek forall a b. (a -> b) -> a -> b
$ FTFC_Instance -> FT_Face
fontFace FTFC_Instance
font
    FT_SizeRec
size' <- forall a. Storable a => Ptr a -> IO a
peek forall a b. (a -> b) -> a -> b
$ FT_FaceRec -> FT_Size
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_Fixed
strength = forall a b. (Integral a, Num b) => a -> b
fromIntegral (FT_FaceRec -> FT_UShort
frUnits_per_EM FT_FaceRec
face')forall a. Num a => a -> a -> a
*FT_Size_Metrics -> FT_Fixed
smY_scale (FT_SizeRec -> FT_Size_Metrics
srMetrics FT_SizeRec
size')forall a. Integral a => a -> a -> a
`div`FT_Fixed
24
    FT_GlyphSlotRec
glyph' <- forall a. Storable a => Ptr a -> IO a
peek forall a b. (a -> b) -> a -> b
$ FT_FaceRec -> FT_GlyphSlot
frGlyph FT_FaceRec
face'

    FT_GlyphSlotRec
glyph1' <- case FT_GlyphSlotRec -> FT_UInt
gsrFormat FT_GlyphSlotRec
glyph' of
        FT_UInt
FT_GLYPH_FORMAT_OUTLINE | FTFC_Instance -> Bool
fontEmbolden FTFC_Instance
font -> do
            FT_Outline
outline <- forall a b. Storable a => a -> (Ptr a -> IO b) -> IO a
withPtr (FT_GlyphSlotRec -> FT_Outline
gsrOutline FT_GlyphSlotRec
glyph') forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip Ptr FT_Outline -> FT_Fixed -> IO ()
ft_Outline_Embolden FT_Fixed
strength
            forall (m :: * -> *) a. Monad m => a -> m a
return FT_GlyphSlotRec
glyph' { gsrOutline :: FT_Outline
gsrOutline = FT_Outline
outline }
        FT_UInt
_ -> 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;
        FTFC_Subpixel
_ | Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ FTFC_Instance -> Bool
fontAntialias FTFC_Instance
font -> FTFC_Instance -> Int
fontRenderFlags FTFC_Instance
font;
        FTFC_Subpixel
SubpixelNone -> FTFC_Instance -> Int
fontRenderFlags FTFC_Instance
font;
        FTFC_Subpixel
SubpixelHorizontalRGB -> Int
ft_RENDER_MODE_LCD;
        FTFC_Subpixel
SubpixelHorizontalBGR -> Int
ft_RENDER_MODE_LCD;
        FTFC_Subpixel
SubpixelVerticalRGB -> Int
ft_RENDER_MODE_LCD_V;
        FTFC_Subpixel
SubpixelVerticalBGR -> Int
ft_RENDER_MODE_LCD_V;
        FTFC_Subpixel
SubpixelDefault -> FTFC_Instance -> Int
fontRenderFlagsSubpixel FTFC_Instance
font}
    let bgr :: Bool
bgr = case FTFC_Subpixel
subpixel of {
        FTFC_Subpixel
_ | Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ FTFC_Instance -> Bool
fontAntialias FTFC_Instance
font -> Bool
False;
        FTFC_Subpixel
SubpixelNone -> Bool
False;
        FTFC_Subpixel
SubpixelHorizontalRGB -> Bool
False;
        FTFC_Subpixel
SubpixelHorizontalBGR -> Bool
True;
        FTFC_Subpixel
SubpixelVerticalRGB -> Bool
False;
        FTFC_Subpixel
SubpixelVerticalBGR -> Bool
True;
        FTFC_Subpixel
SubpixelDefault -> FTFC_Instance -> Bool
fontBGR FTFC_Instance
font}

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

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

    a
img <- FT_Bitmap -> IO a
cb forall a b. (a -> b) -> a -> b
$ FT_GlyphSlotRec -> FT_Bitmap
gsrBitmap FT_GlyphSlotRec
glyph2'
    forall (m :: * -> *) a. Monad m => a -> m a
return Glyph {
        glyphFontName :: Maybe FilePath
glyphFontName = FTFC_Instance -> Maybe FilePath
fontName FTFC_Instance
font, glyphImage :: a
glyphImage = a
img,
        glyphAdvance :: (Double, Double)
glyphAdvance = (forall a b. (Integral a, Num b) => a -> b
fromIntegral (FT_Vector -> FT_Fixed
vX forall a b. (a -> b) -> a -> b
$ FT_GlyphSlotRec -> FT_Vector
gsrAdvance FT_GlyphSlotRec
glyph2') forall a. Fractional a => a -> a -> a
/ Double
64 forall a. Num a => a -> a -> a
*
            if FTFC_Instance -> Bool
fontPixelFixupEstimated FTFC_Instance
font then FTFC_Instance -> Double
fontPixelSizeFixup FTFC_Instance
font else Double
1,
            forall a b. (Integral a, Num b) => a -> b
fromIntegral (FT_Vector -> FT_Fixed
vY forall a b. (a -> b) -> a -> b
$ FT_GlyphSlotRec -> FT_Vector
gsrAdvance FT_GlyphSlotRec
glyph2') forall a. Fractional a => a -> a -> a
/ Double
64 forall a. Num a => a -> a -> a
*
            if FTFC_Instance -> Bool
fontPixelFixupEstimated FTFC_Instance
font then FTFC_Instance -> Double
fontPixelSizeFixup FTFC_Instance
font else Double
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 -> FT_UInt -> IO (FT_Bitmap, FT_Glyph_Metrics)
bmpAndMetricsForIndex FTFC_Instance
inst FTFC_Subpixel
subpixel FT_UInt
index = do
    FTFC_Glyph FT_Bitmap
glyph <- forall a.
FTFC_Instance
-> FT_UInt
-> FTFC_Subpixel
-> (FT_Bitmap -> IO a)
-> IO (FTFC_Glyph a)
glyphForIndex FTFC_Instance
inst FT_UInt
index FTFC_Subpixel
subpixel forall (f :: * -> *) a. Applicative f => a -> f a
pure
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. FTFC_Glyph a -> a
glyphImage FTFC_Glyph FT_Bitmap
glyph, 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 :: forall a b. Storable a => a -> (Ptr a -> IO b) -> IO a
withPtr a
a Ptr a -> IO b
cb = forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca forall a b. (a -> b) -> a -> b
$ \Ptr a
a' -> do
    forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr a
a' a
a
    Ptr a -> IO b
cb Ptr a
a'
    forall a. Storable a => Ptr a -> IO a
peek Ptr a
a'

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

m22toFt :: M22 Double -> FT_Matrix
m22toFt :: M22 Double -> FT_Matrix
m22toFt (V2 (V2 Double
xx Double
xy) (V2 Double
yx Double
yy)) = FT_Matrix {
    mXx :: FT_Fixed
mXx = Double -> FT_Fixed
c Double
xx forall a. Num a => a -> a -> a
* FT_Fixed
0x10000, mXy :: FT_Fixed
mXy = Double -> FT_Fixed
c Double
xy forall a. Num a => a -> a -> a
* FT_Fixed
0x10000,
    mYx :: FT_Fixed
mYx = Double -> FT_Fixed
c Double
yx forall a. Num a => a -> a -> a
* FT_Fixed
0x10000, mYy :: FT_Fixed
mYy = Double -> FT_Fixed
c Double
yy forall a. Num a => a -> a -> a
* FT_Fixed
0x10000
  } where c :: Double -> FT_Fixed
c = forall a. Enum a => Int -> a
toEnum forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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                     = Int
0
ft_LOAD_NO_SCALE :: Int
ft_LOAD_NO_SCALE                    = Int
1
ft_LOAD_NO_HINTING :: Int
ft_LOAD_NO_HINTING                  = Int
2
ft_LOAD_RENDER :: Int
ft_LOAD_RENDER                      = Int
4
ft_LOAD_NO_BITMAP :: Int
ft_LOAD_NO_BITMAP                   = Int
8
ft_LOAD_VERTICAL_LAYOUT :: Int
ft_LOAD_VERTICAL_LAYOUT             = Int
16
ft_LOAD_FORCE_AUTOHINT :: Int
ft_LOAD_FORCE_AUTOHINT              = Int
32
ft_LOAD_CROP_BITMAP :: Int
ft_LOAD_CROP_BITMAP                 = Int
64
ft_LOAD_PEDANTIC :: Int
ft_LOAD_PEDANTIC                    = Int
128
ft_LOAD_IGNORE_GLOBAL_ADVANCE_WIDTH :: Int
ft_LOAD_IGNORE_GLOBAL_ADVANCE_WIDTH = Int
512
ft_LOAD_NO_RECURSE :: Int
ft_LOAD_NO_RECURSE                  = Int
1024
ft_LOAD_IGNORE_TRANSFORM :: Int
ft_LOAD_IGNORE_TRANSFORM            = Int
2048
ft_LOAD_MONOCHROME :: Int
ft_LOAD_MONOCHROME                  = Int
4096
ft_LOAD_LINEAR_DESIGN :: Int
ft_LOAD_LINEAR_DESIGN               = Int
8192
ft_LOAD_NO_AUTOHINT :: Int
ft_LOAD_NO_AUTOHINT                 = Int
32768
ft_LOAD_COLOR :: Int
ft_LOAD_COLOR                       = Int
1048576
ft_LOAD_COMPUTE_METRICS :: Int
ft_LOAD_COMPUTE_METRICS             = Int
2097152
ft_LOAD_BITMAP_METRICS_ONLY :: Int
ft_LOAD_BITMAP_METRICS_ONLY         = Int
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 = Int
0
ft_LOAD_TARGET_LIGHT :: Int
ft_LOAD_TARGET_LIGHT  = Int
65536
ft_LOAD_TARGET_MONO :: Int
ft_LOAD_TARGET_MONO   = Int
131072
ft_LOAD_TARGET_LCD :: Int
ft_LOAD_TARGET_LCD    = Int
196608
ft_LOAD_TARGET_LCD_V :: Int
ft_LOAD_TARGET_LCD_V  = Int
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 = Int
0
ft_RENDER_MODE_LIGHT :: Int
ft_RENDER_MODE_LIGHT  = Int
1
ft_RENDER_MODE_MONO :: Int
ft_RENDER_MODE_MONO   = Int
2
ft_RENDER_MODE_LCD :: Int
ft_RENDER_MODE_LCD    = Int
3
ft_RENDER_MODE_LCD_V :: Int
ft_RENDER_MODE_LCD_V  = Int
4