FontConfig.hs

{-# LANGUAGE CApiFFI, OverloadedStrings #-}
-- | Convert between FontConfig & FreeType types.
module FreeType.FontConfig(charIndex,
        fontCharSet, fontCharSetAndSpacing, fontQuery, fontQueryAll, fontQueryFace,
        FTFC_Instance(..), FTFC_Metrics(..), FTFC_Subpixel(..), FTFC_Glyph(..),
        instantiatePattern, glyphForIndex, bmpAndMetricsForIndex) where

--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, 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(..))

-- | 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.
foreign import capi "fontconfig-wrap.h fcFreeTypeCharIndex" charIndex :: FT_Face -> Char -> Word

-- | Scans a FreeType face and returns the set of encoded Unicode chars.
fontCharSet :: FT_Face -> CharSet'
fontCharSet arg = fromMessage0 $ fcFreeTypeCharSet arg

foreign import capi "fontconfig-wrap.h" fcFreeTypeCharSet :: FT_Face -> Ptr Int -> CString

data Spacing = Mono -- ^ A font where all glyphs have the same width
    | Dual -- ^ The font has glyphs in precisely two widths
    | Proportional -- ^ The font has glyphs of many widths
    | SpacingError -- ^ Unexpected & invalid spacing value.
    deriving (Read, Show, Eq, Enum, Bounded)

-- | Scans a FreeType face and returns the set of encoded Unicode chars & the computed spacing type.
fontCharSetAndSpacing :: FT_Face -> (Spacing, CharSet')
fontCharSetAndSpacing arg = (toEnum spacing, chars)
  where (spacing, chars) = fromMessage0 $ fcFreeTypeCharSetAndSpacing arg

foreign import capi "fontconfig-wrap.h" fcFreeTypeCharSetAndSpacing ::
    FT_Face -> Ptr Int -> CString

-- | Constructs a pattern representing the 'id'th face in 'file'.
-- The number of faces in 'file' is returned in 'count'.
fontQuery :: FilePath -> Int -> (Int, Pattern)
fontQuery a b = fromMessage0 $ flip withCString' a $ \a' -> fcFreeTypeQuery a' b

foreign import capi "fontconfig-wrap.h" fcFreeTypeQuery ::
    CString -> Int -> Ptr Int -> CString

-- | Constructs patterns found in 'file', all patterns found in 'file' are added to 'set'.
-- The number of faces in 'file' is returned in 'count'.
-- The number of patterns added to 'set' is returned.
fontQueryAll :: FilePath -> (Int, Int, FontSet)
fontQueryAll a = fromMessage0 $ withCString' fcFreeTypeQueryAll a

foreign import capi "fontconfig-wrap.h" fcFreeTypeQueryAll ::
    CString -> Ptr Int -> CString

-- | Constructs a pattern representing 'face'. 'file' and 'id' are used solely
-- as data for pattern elements (FC_FILE, FC_INDEX and sometimes FC_FAMILY).
fontQueryFace :: FT_Face -> FilePath -> Int -> Pattern
fontQueryFace a b c = fromMessage0 $ flip withCString' b $ \b' -> fcFreeTypeQueryFace a b' $ fromEnum c

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

-- | Convience API around `glyphForIndex` to retrieve the image & metrics of the font's glyph.
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