@@ 1,16 1,35 @@
-{-# LANGUAGE CApiFFI #-}
+{-# LANGUAGE CApiFFI, OverloadedStrings #-}
module FreeType.FontConfig where
-import FreeType.Core.Base (FT_Face)
+--import FreeType.Core.Base (FT_Face)
import Foreign.Ptr (Ptr)
import Foreign.C.String (CString)
import Graphics.Text.Font.Choose.CharSet (CharSet')
-import Graphics.Text.Font.Choose.Pattern (Pattern)
+import Graphics.Text.Font.Choose.Pattern (Pattern, getValue, getValues)
import Graphics.Text.Font.Choose.FontSet (FontSet)
import Graphics.Text.Font.Choose.Internal.FFI (fromMessage0, withCString')
+-- For FcFt transliteration
+import Graphics.Text.Font.Choose.Value (Value(..))
+
+import Data.Maybe (fromMaybe, fromJust)
+import Linear.V2 (V2(..))
+import Linear.Matrix(M22)
+import Data.Bits ((.|.))
+import Data.Word (Word32)
+
+import Foreign.Storable (Storable(..))
+import Control.Exception (catch, throw)
+import Foreign.Marshal.Alloc (alloca)
+
+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(..))
+
foreign import capi "fontconfig-wrap.h fcFreeTypeCharIndex" charIndex :: FT_Face -> Char -> Word
fontCharSet :: FT_Face -> CharSet'
@@ 41,3 60,292 @@ fontQueryFace a b c = fromMessage0 $ flip withCString' b $ \b' -> fcFreeTypeQuer
foreign import capi "fontconfig-wrap.h" fcFreeTypeQueryFace ::
FT_Face -> CString -> Int -> Ptr Int -> CString
+
+ ------
+--- Transliterated from FcFt
+--- https://codeberg.org/dnkl/fcft/
+--- Untested
+------
+
+-- | A `FT_Face` queried from FontConfig with glyph-loading parameters.
+data FTFC_Instance = Instance {
+ fontName :: Maybe 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
+}
+-- | Results queried from FontConfig with caller-relevant properties,
+-- notably relating to layout.
+data FTFC_Metrics = Metrics {
+ height :: Int,
+ descent :: Int,
+ ascent :: Int,
+ maxAdvance :: (Int, Int), -- Width/height of font's widest glyph.
+ metricsAntialias :: Bool,
+ metricsSubpixel :: FTFC_Subpixel,
+ 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 ftlib pattern (req_pt_size, req_px_size) = do
+ let dpi = fromMaybe 75 $ getValue "dpi" pattern :: Double
+
+ ft_face <- case () of --getValue "ftface" pattern of
+ -- ValueFTFace x -> return x
+ _ -> ft_New_Face ftlib (fromJust $ getValue "file" pattern) -- is a mutex needed?
+ (toEnum $ fromMaybe 0 $ getValue "index" pattern)
+
+ ft_Set_Pixel_Sizes ft_face 0 $ toEnum $ fromEnum $
+ fromMaybe req_px_size $ getValue "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
+ Just (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 :: Int
+ lcdfilter = case fromMaybe 1 $ getValue "lcdfilter" pattern of
+ 3 -> 16
+ x -> x
+ case getValue "matrix" pattern of
+ Just (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 = getValue "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 = getValue "fullname" pattern
+ }
+ }
+
+-- | Results from `glyphForIndex`.
+data FTFC_Glyph a = Glyph {
+ glyphFontName :: Maybe String,
+ glyphImage :: a,
+ glyphAdvance :: (Double, Double),
+ glyphSubpixel :: FTFC_Subpixel,
+ 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 font index subpixel cb = do
+ ft_Load_Glyph (fontFace font) index (toEnum $ fontLoadFlags font)
+ face' <- peek $ fontFace font
+ size' <- peek $ frSize face'
+ -- Formula from old FreeType function `FT_GlyphSlotEmbolden`.
+ -- Approximate as fallback for fonts not using fontsets or variables axis.
+ let strength = fromIntegral (frUnits_per_EM face')*smY_scale (srMetrics size')`div`24
+ glyph' <- peek $ frGlyph face'
+
+ glyph1' <- case gsrFormat glyph' of
+ FT_GLYPH_FORMAT_OUTLINE | fontEmbolden font -> do
+ outline <- withPtr (gsrOutline glyph') $ flip ft_Outline_Embolden strength
+ return glyph' { gsrOutline = outline }
+ _ -> return glyph'
+
+ let render_flags = case 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;
+ _ | not $ fontAntialias font -> fontRenderFlags font;
+ SubpixelNone -> fontRenderFlags font;
+ SubpixelHorizontalRGB -> ft_RENDER_MODE_LCD;
+ SubpixelHorizontalBGR -> ft_RENDER_MODE_LCD;
+ SubpixelVerticalRGB -> ft_RENDER_MODE_LCD_V;
+ SubpixelVerticalBGR -> ft_RENDER_MODE_LCD_V;
+ SubpixelDefault -> fontRenderFlagsSubpixel font}
+ {-let bgr = case subpixel of
+ _ | not $ fontAntialias font -> False
+ SubpixelNone -> False
+ SubpixelHorizontalRGB -> False
+ SubpixelHorizontalBGR -> True
+ SubpixelVerticalRGB -> False
+ SubpixelVerticalBGR -> True
+ SubpixelDefault -> fontBGR font-}
+
+ can_set_lcd_filter <- isSuccess $ ft_Library_SetLcdFilter (gsrLibrary glyph1') 0
+ -- FIXME: Do we need a mutex?
+ let set_lcd_filter = ft_Library_SetLcdFilter (gsrLibrary glyph1') $ fontLCDFilter font
+ case render_flags of {
+ FT_RENDER_MODE_LCD | can_set_lcd_filter -> set_lcd_filter;
+ FT_RENDER_MODE_LCD_V | can_set_lcd_filter -> set_lcd_filter;
+ _ -> return ()}
+
+ glyph2' <- case gsrFormat glyph1' of {
+ FT_GLYPH_FORMAT_BITMAP -> return glyph1';
+ _ -> withPtr glyph1' $ flip ft_Render_Glyph $ toEnum render_flags}
+ -- If set_lcd_filter requires mutex, release it here.
+ case gsrFormat glyph2' of {
+ FT_GLYPH_FORMAT_BITMAP -> return ();
+ _ -> throw $ FtError "glyphForIndex" 2
+ }
+
+ img <- cb $ gsrBitmap glyph2'
+ return Glyph {
+ glyphFontName = fontName font, glyphImage = img,
+ glyphAdvance = (fromIntegral (vX $ gsrAdvance glyph2') / 64 *
+ if fontPixelFixupEstimated font then fontPixelSizeFixup font else 1,
+ fromIntegral (vY $ gsrAdvance glyph2') / 64 *
+ if fontPixelFixupEstimated font then fontPixelSizeFixup font else 1),
+ glyphSubpixel = subpixel,
+ glyphMetrics = gsrMetrics glyph2'
+ }
+
+bmpAndMetricsForIndex ::
+ FTFC_Instance -> FTFC_Subpixel -> Word32 -> IO (FT_Bitmap, FT_Glyph_Metrics)
+bmpAndMetricsForIndex inst subpixel index = do
+ glyph <- glyphForIndex inst index subpixel pure
+ return (glyphImage glyph, glyphMetrics glyph)
+
+withPtr :: Storable a => a -> (Ptr a -> IO b) -> IO a
+withPtr a cb = alloca $ \a' -> do
+ poke a' a
+ _ <- cb a'
+ peek a'
+
+isSuccess :: IO a -> IO Bool
+isSuccess cb = do
+ _ <- cb
+ return True
+ `catch` \(FtError _ _) -> return False
+
+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
@@ 17,12 17,12 @@ import Graphics.Text.Font.Choose.ObjectSet
import Graphics.Text.Font.Choose.Result
import Graphics.Text.Font.Choose.Weight
-import Stylist (StyleSheet(..), PropertyParser(..))
-import Stylist.Parse (parseProperties)
-import Data.CSS.Syntax.Tokens (Token(..), NumericValue(..), serialize)
+import Stylist (PropertyParser(..))
+import Data.CSS.Syntax.Tokens (Token(..), NumericValue(..))
import Data.Text (Text, unpack)
import Data.Scientific (toRealFloat)
import Data.List (intercalate)
+import Data.Maybe as Mb (listToMaybe, fromMaybe, mapMaybe)
type Pattern = Map Text [(Binding, Value)]
data Pattern' = Pattern' { unPattern :: Pattern }
@@ 44,6 44,11 @@ setValue key strength v self = setValues key strength [v] self
setValues :: ToValue v => Text -> Binding -> [v] -> Pattern -> Pattern
setValues key strength vs self = M.insert key [(strength, toValue v) | v <- vs] self
+getValue :: ToValue v => Text -> Pattern -> Maybe v
+getValue key self = fromValue . snd =<< listToMaybe =<< M.lookup key self
+getValues :: ToValue v => Text -> Pattern -> [v]
+getValues key self = Mb.mapMaybe (fromValue . snd) $ fromMaybe [] $ M.lookup key self
+
equalSubset :: Pattern -> Pattern -> ObjectSet -> Bool
equalSubset a b os = case withMessage fcPatternEqualSubset [toObject a, toObject b, toObject os] of
0 -> False
@@ 77,35 82,36 @@ foreign import capi "fontconfig-wrap.h" fcNameFormat :: CString -> Int -> CStrin
------
parseFontFamily :: [Token] -> ([String], Bool, [Token])
-parseFontFamily (String font:Comma:tail) = let (fonts, b, tail') = parseFontFamily tail
+parseFontFamily (String font:Comma:toks) = let (fonts, b, tail') = parseFontFamily toks
in (unpack font:fonts, b, tail')
-parseFontFamily (Ident font:Comma:tail) = let (fonts, b, tail') = parseFontFamily tail
+parseFontFamily (Ident font:Comma:toks) = let (fonts, b, tail') = parseFontFamily toks
in (unpack font:fonts, b, tail')
-parseFontFamily (String font:tail) = ([unpack font], True, tail)
-parseFontFamily (Ident font:tail) = ([unpack font], True, tail)
+parseFontFamily (String font:toks) = ([unpack font], True, toks)
+parseFontFamily (Ident font:toks) = ([unpack font], True, toks)
parseFontFamily toks = ([], False, toks) -- Invalid syntax!
parseFontFeatures :: [Token] -> ([(String, Int)], Bool, [Token])
parseFontFeatures (String feat:toks) | feature@(_:_:_:_:[]) <- unpack feat = case toks of
- Comma:tail -> let (feats, b, tail') = parseFontFeatures tail in ((feature, 1):feats, b, tail')
- Ident "on":Comma:tail -> let (f, b, t) = parseFontFeatures tail in ((feature, 1):f, b, t)
- Ident "on":tail -> ([(feature, 1)], True, tail)
- Ident "off":Comma:tail -> let (f, b, t) = parseFontFeatures tail in ((feature, 1):f, b, t)
- Ident "off":tail -> ([(feature, 1)], True, tail)
- Number _ (NVInteger x):Comma:tail ->
- let (feats, b, tail') = parseFontFeatures tail in ((feature, fromEnum x):feats, b, tail')
- Number _ (NVInteger x):tail -> ([(feature, fromEnum x)], True, tail)
+ Comma:toks' -> let (feats, b, tail') = parseFontFeatures toks' in ((feature, 1):feats, b, tail')
+ Ident "on":Comma:toks' -> let (f, b, t) = parseFontFeatures toks' in ((feature, 1):f, b, t)
+ Ident "on":toks' -> ([(feature, 1)], True, toks')
+ Ident "off":Comma:toks' -> let (f, b, t) = parseFontFeatures toks' in ((feature, 1):f, b, t)
+ Ident "off":toks' -> ([(feature, 1)], True, toks')
+ Number _ (NVInteger x):Comma:toks' ->
+ let (feats, b, tail') = parseFontFeatures toks' in ((feature, fromEnum x):feats, b, tail')
+ Number _ (NVInteger x):toks' -> ([(feature, fromEnum x)], True, toks')
+ _ -> ([], False, String feat:toks)
parseFontFeatures toks = ([], False, toks)
parseFontVars :: [Token] -> ([(String, Double)], Bool, [Token])
-parseFontVars (String var':Number _ x:Comma:tail) | var@(_:_:_:_:[]) <- unpack var' =
- let (vars, b, tail') = parseFontVars tail in ((var, nv2double x):vars, b, tail')
-parseFontVars (String var':Number _ x:tail) | var@(_:_:_:_:[]) <- unpack var' =
- ([(var, nv2double x)], True, tail)
+parseFontVars (String var':Number _ x:Comma:toks) | var@(_:_:_:_:[]) <- unpack var' =
+ let (vars, b, tail') = parseFontVars toks in ((var, nv2double x):vars, b, tail')
+parseFontVars (String var':Number _ x:toks) | var@(_:_:_:_:[]) <- unpack var' =
+ ([(var, nv2double x)], True, toks)
parseFontVars toks = ([], False, toks)
parseLength :: Double -> NumericValue -> Text -> Double
-parseLength super length unit = convert (nv2double length) unit
+parseLength super len unit = convert (nv2double len) unit
where
convert = c
c x "pt" = x -- Unit FontConfig expects!
@@ 140,14 146,20 @@ parseFontWeight (Ident "bold") = Just 200
parseFontWeight (Number _ (NVInteger x)) = Just $ weightFromOpenType $ fromEnum x
parseFontWeight _ = Nothing
+nv2double :: NumericValue -> Double
nv2double (NVInteger x) = fromInteger x
nv2double (NVNumber x) = toRealFloat x
+sets :: ToValue v => Text -> Binding -> [v] -> Pattern -> Maybe Pattern
sets a b c d = Just $ setValues a b c d
+set :: ToValue v => Text -> Binding -> v -> Pattern -> Maybe Pattern
set a b c d = Just $ setValue a b c d
+seti :: Text -> Binding -> Int -> Pattern -> Maybe Pattern
seti a b c d = Just $ setValue a b (c :: Int) d
+unset' :: Text -> Pattern -> Maybe Pattern
unset' a b = Just $ M.delete a b
+getSize :: Pattern -> Double
getSize pat | Just [(_, ValueDouble x)] <- M.lookup "size" pat = x
| otherwise = 10