-- 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