-- NOTE: Not tested
module FreeType.FontConfig (ftCharIndex, ftCharSet, ftCharSetAndSpacing,
ftQuery, ftQueryAll, ftQueryFace) 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 (peek)
import Foreign.Marshal.Alloc (alloca)
import Foreign.C.String (CString, withCString)
import System.IO.Unsafe (unsafePerformIO)
import Control.Exception (throw)
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 FreeType.Core.Base (FT_Library, ft_New_Face, ft_Set_Pixel_Sizes, ft_Set_Transform,
FT_FaceRec(..), FT_SizeRec(..), FT_Size_Metrics(..))
import FreeType.Control.Subpixel (FT_LcdFilter)
import FreeType.Core.Types (FT_Matrix(..))
import Linear.V2 (V2(..))
import Linear.Matrix(M22)
import Data.Bits ((.|.))
c2w :: Char -> Word32
c2w = fromIntegral . fromEnum
ftCharIndex :: FT_Face -> Char -> Word
ftCharIndex face = fcFreeTypeCharIndex face . c2w
foreign import ccall "FcFreeTypeCharIndex" fcFreeTypeCharIndex :: FT_Face -> Word32 -> Word
ftCharSet :: FT_Face -> CharSet
ftCharSet face = unsafePerformIO $ thawCharSet_ $ fcFreeTypeCharSet face nullPtr
foreign import ccall "FcFreeTypeCharSet" fcFreeTypeCharSet
:: FT_Face -> Ptr () -> IO CharSet_ -- 2nd arg's deprecated!
data Spacing = Proportional | Dual | Mono
ftCharSetAndSpacing :: FT_Face -> (CharSet, Spacing)
ftCharSetAndSpacing face = unsafePerformIO $ alloca $ \spacing' -> do
chars <- thawCharSet_ $ fcFreeTypeCharSetAndSpacing face nullPtr spacing'
spacing_ <- peek spacing'
let spacing = case spacing_ of{
0 -> Proportional;
90 -> Dual;
100 -> Mono;
_ -> throw ErrTypeMismatch}
return (chars, spacing)
foreign import ccall "FcFreeTypeCharSetAndSpacing" fcFreeTypeCharSetAndSpacing ::
FT_Face -> Ptr () -> Ptr Int -> IO CharSet_ -- 2nd arg's deprecated!
ftQuery :: FilePath -> Int -> IO (Pattern, Int)
ftQuery filename id = withCString filename $ \filename' -> alloca $ \count' -> do
pattern <- thawPattern_ $ fcFreeTypeQuery filename' id nullPtr count'
count <- peek count'
return (pattern, count)
foreign import ccall "FcFreeTypeQuery" fcFreeTypeQuery ::
CString -> Int -> Ptr () -> Ptr Int -> IO Pattern_ -- 3rd arg's deprecated!
ftQueryAll :: FilePath -> Int -> IO (FontSet, Int)
ftQueryAll filename id = withCString filename $ \filename' -> alloca $ \count' ->
withFontSet [] $ \fonts' -> do
fcFreeTypeQueryAll filename' id nullPtr count' fonts'
fonts <- thawFontSet fonts'
count <- peek count'
return (fonts, count)
foreign import ccall "FcFreeTypeQueryAll" fcFreeTypeQueryAll ::
CString -> Int -> Ptr () -> Ptr Int -> FontSet_ -> IO Word -- 2nd arg's deprecated!
ftQueryFace :: FT_Face -> FilePath -> Int -> IO Pattern
ftQueryFace face filename id = withCString filename $ \filename' ->
thawPattern_ $ fcFreeTypeQueryFace face filename' id 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/
------
data FTFC_Instance = Instance {
fontName :: String,
fontPath :: Maybe String,
fontFace :: FT_Face,
fontLoadFlags :: Int,
fontAntialias :: Bool,
fontEmbolden :: Bool,
fontIsColor :: Bool,
fontRenderFlags :: Int,
fontRenderFlagsSubpixel :: Int,
fontPixelSizeFixup :: Double,
fontPixelFixupEstimated :: Bool,
fontBGR :: Bool,
fontLCDFilter :: FT_LcdFilter,
fontFeats :: [String], -- Callers probably want to validate via harfbuzz
fontMetrics :: FTFC_Metrics
}
data FTFC_Metrics = Metrics {
height :: Int,
descent :: Int,
ascent :: Int,
maxAdvance :: (Int, Int),
metricsAntialias :: Bool,
metricsSubpixel :: Subpixel,
metricsName :: String
}
data Subpixel = SubpixelNone | SubpixelHorizontalRGB | SubpixelHorizontalBGR |
SubpixelVerticalRGB | SubpixelVerticalBGR
instantiatePattern :: FT_Library -> Pattern -> (Double, Double) -> IO FTFC_Instance
instantiatePattern ftlib pattern (req_pt_size, req_px_size) = do
let dpi = fromMaybe 75 $ getValue' "dpi" pattern :: Double
let size = fromMaybe req_pt_size $ getValue' "size" pattern
ft_face <- case getValue "ftface" pattern of
ValueFTFace x -> return x
_ -> ft_New_Face ftlib (getValue0 "file" pattern) -- is a mutex needed?
(toEnum $ fromMaybe 0 $ getValue' "index" pattern)
ft_Set_Pixel_Sizes ft_face 0 $ toEnum $ getValue0 "pixelsize" pattern
let scalable = fromMaybe True $ getValue' "scalable" pattern
let outline = fromMaybe True $ getValue' "outline" pattern
(pixel_fixup, fixup_estimated) <- case getValue "pixelsizefixupfactor" pattern of
ValueDouble x -> return (x, False)
_ | scalable && not outline -> do
let px_size = if req_px_size < 0 then req_pt_size * dpi / 72 else req_px_size
ft_face' <- peek ft_face
size' <- peek $ frSize ft_face'
return (px_size / (fromIntegral $ smY_ppem $ srMetrics size'), True)
_ -> return (1, False)
let hinting = fromMaybe True $ getValue' "hinting" pattern
let antialias = fromMaybe True $ getValue' "antialias" pattern
let hintstyle = fromMaybe 1 $ getValue' "hintstyle" pattern :: Int
let rgba = fromMaybe 0 $ getValue' "rgba" pattern :: Int
let load_flags | not antialias && (not hinting || hintstyle == 0) =
ft_LOAD_NO_HINTING .|. ft_LOAD_MONOCHROME
| not antialias = ft_LOAD_MONOCHROME
| not hinting || hintstyle == 0 = ft_LOAD_NO_HINTING
| otherwise = ft_LOAD_DEFAULT
let load_target | not antialias && hinting && hintstyle /= 0 = ft_LOAD_TARGET_MONO
| not antialias = ft_LOAD_TARGET_NORMAL
| not hinting || hintstyle == 0 = ft_LOAD_TARGET_NORMAL
| hintstyle == 1 = ft_LOAD_TARGET_LIGHT
| hintstyle == 2 = ft_LOAD_TARGET_NORMAL
| rgba `elem` [1, 2] = ft_LOAD_TARGET_LCD
| rgba `elem` [3, 4] = ft_LOAD_TARGET_LCD_V
| otherwise = ft_LOAD_TARGET_NORMAL
let embedded_bitmap = fromMaybe True $ getValue' "embeddedbitmap" pattern
let load_flags1 | embedded_bitmap = load_flags .|. ft_LOAD_NO_BITMAP
| otherwise = load_flags
let autohint = fromMaybe False $ getValue' "autohint" pattern
let load_flags2 | autohint = load_flags .|. ft_LOAD_FORCE_AUTOHINT
| otherwise = load_flags
let render_flags_normal | not antialias = ft_RENDER_MODE_MONO
| otherwise = ft_RENDER_MODE_NORMAL
let render_flags_subpixel | not antialias = ft_RENDER_MODE_MONO
| rgba `elem` [1, 2] = ft_RENDER_MODE_LCD
| rgba `elem` [3, 4] = ft_RENDER_MODE_LCD_V
| otherwise = ft_RENDER_MODE_NORMAL
let lcdfilter = case fromMaybe 1 $ getValue' "lcdfilter" pattern :: Int of {
3 -> 16; x -> x}
case getValue "matrix" pattern of
ValueMatrix m -> ft_Set_Transform ft_face (Just $ m22toFt m) Nothing
_ -> return ()
ft_face' <- peek ft_face
size' <- peek $ frSize ft_face'
let metrics' = srMetrics size'
let c x = fromIntegral x / 64 * pixel_fixup
return Instance {
fontName = getValue0 "fullname" pattern,
fontPath = getValue' "file" pattern,
fontFace = ft_face,
fontLoadFlags = load_target .|. load_flags .|. ft_LOAD_COLOR,
fontAntialias = antialias,
fontEmbolden = fromMaybe False $ getValue' "embolden" pattern,
fontIsColor = fromMaybe False $ getValue' "color" pattern,
fontRenderFlags = render_flags_normal,
fontRenderFlagsSubpixel = render_flags_subpixel,
fontPixelSizeFixup = pixel_fixup,
fontPixelFixupEstimated = fixup_estimated,
fontBGR = rgba `elem` [2, 4],
fontLCDFilter = toEnum lcdfilter,
fontFeats = getValues' "fontfeatures" pattern,
fontMetrics = Metrics {
height = fromEnum $ c $ smHeight metrics',
descent = fromEnum $ c $ smDescender metrics',
ascent = fromEnum $ c $ smAscender metrics',
maxAdvance = (fromEnum $ c $ smMax_advance metrics',
fromEnum $ c $ smHeight metrics'),
metricsAntialias = antialias,
metricsSubpixel = case rgba of
_ | not antialias -> SubpixelNone
1 -> SubpixelHorizontalRGB
2 -> SubpixelHorizontalBGR
3 -> SubpixelVerticalRGB
4 -> SubpixelVerticalBGR
_ -> SubpixelNone,
metricsName = getValue0 "fullname" pattern
}
}
m22toFt :: M22 Double -> FT_Matrix
m22toFt (V2 (V2 xx xy) (V2 yx yy)) = FT_Matrix {
mXx = c xx * 0x10000, mXy = c xy * 0x10000,
mYx = c yx * 0x10000, mYy = c yy * 0x10000
} where c = toEnum . 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 = 0
ft_LOAD_NO_SCALE = 1
ft_LOAD_NO_HINTING = 2
ft_LOAD_RENDER = 4
ft_LOAD_NO_BITMAP = 8
ft_LOAD_VERTICAL_LAYOUT = 16
ft_LOAD_FORCE_AUTOHINT = 32
ft_LOAD_CROP_BITMAP = 64
ft_LOAD_PEDANTIC = 128
ft_LOAD_IGNORE_GLOBAL_ADVANCE_WIDTH = 512
ft_LOAD_NO_RECURSE = 1024
ft_LOAD_IGNORE_TRANSFORM = 2048
ft_LOAD_MONOCHROME = 4096
ft_LOAD_LINEAR_DESIGN = 8192
ft_LOAD_NO_AUTOHINT = 32768
ft_LOAD_COLOR = 1048576
ft_LOAD_COMPUTE_METRICS = 2097152
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 = 0
ft_LOAD_TARGET_LIGHT = 65536
ft_LOAD_TARGET_MONO = 131072
ft_LOAD_TARGET_LCD = 196608
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 = 0
ft_RENDER_MODE_LIGHT = 1
ft_RENDER_MODE_MONO = 2
ft_RENDER_MODE_LCD = 3
ft_RENDER_MODE_LCD_V = 4