packages feed

fontconfig-pure (empty) → 0.1.0.0

raw patch · 22 files changed

+2260/−0 lines, 22 filesdep +QuickCheckdep +basedep +containerssetup-changed

Dependencies added: QuickCheck, base, containers, css-syntax, fontconfig-pure, freetype2, hashable, hspec, linear, scientific, stylist-traits, text

Files

+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for fontconfig-pure++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ FreeType/FontConfig.hs view
@@ -0,0 +1,381 @@+-- 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 (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 = fromIntegral . 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 face = fcFreeTypeCharIndex face . 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 face = unsafePerformIO $ thawCharSet_ $ fcFreeTypeCharSet face 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 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!++-- | 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 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!++-- | 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 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!++-- | Constructs a pattern representing 'face'.+-- 'filename' and 'id' are used solely as data for pattern elements.+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/+--- 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+    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 = 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+}++-- | 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+    }++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
+ Graphics/Text/Font/Choose.hs view
@@ -0,0 +1,59 @@+module Graphics.Text.Font.Choose(CharSet, FontSet, ObjectSet, Pattern(..), Binding(..),+  Range(..), iRange, StrSet, StrList, Value(..), FontFaceParser(..),++  Config, configCreate,+  configSetCurrent, configGetCurrent, configUptoDate, configHome, configEnableHome,+  configBuildFonts, configBuildFonts', configGetConfigDirs, configGetConfigDirs',+  configGetFontDirs, configGetFontDirs', configGetConfigFiles, configGetConfigFiles',+  configGetCacheDirs, configGetCacheDirs', SetName(..), configGetFonts, configGetFonts',+  configGetRescanInterval,configGetRescanInterval', configAppFontClear,configAppFontClear',+  configAppFontAddFile, configAppFontAddFile', configAppFontAddDir, configAppFontAddDir',+  MatchKind(..), configSubstituteWithPat, configSubstituteWithPat', fontList, fontList', +  configSubstitute, configSubstitute', fontMatch, fontMatch', fontSort, fontSort',+  fontRenderPrepare, fontRenderPrepare', -- configGetFilename, configGetFilename',+  configParseAndLoad, configParseAndLoad', configGetSysRoot, configGetSysRoot',+  configParseAndLoadFromMemory, configParseAndLoadFromMemory',+  configSetSysRoot, configSetSysRoot', configGetFileInfo, configGetFileInfo',++  fontSetList, fontSetList', fontSetMatch, fontSetMatch', fontSetSort, fontSetSort',++  initLoadConfig, initLoadConfigAndFonts, init, fini, reinit, bringUptoDate, version,++  LangSet, defaultLangs, langs, langSetCompare, langNormalize, langCharSet,++  equalSubset, normalizePattern, filter, defaultSubstitute, nameParse, nameUnparse, format,+  setValue, setValues, unset, getValues, getValues', getValue, getValue', getValue0+    ) where++import Prelude hiding (init, filter)++import Graphics.Text.Font.Choose.CharSet (CharSet)+import Graphics.Text.Font.Choose.Config (Config, configCreate,+  configSetCurrent, configGetCurrent, configUptoDate, configHome, configEnableHome,+  configBuildFonts, configBuildFonts', configGetConfigDirs, configGetConfigDirs',+  configGetFontDirs, configGetFontDirs', configGetConfigFiles, configGetConfigFiles',+  configGetCacheDirs, configGetCacheDirs', SetName(..), configGetFonts, configGetFonts',+  configGetRescanInterval,configGetRescanInterval', configAppFontClear,configAppFontClear',+  configAppFontAddFile, configAppFontAddFile', configAppFontAddDir, configAppFontAddDir',+  MatchKind(..), configSubstituteWithPat, configSubstituteWithPat', fontList, fontList', +  configSubstitute, configSubstitute', fontMatch, fontMatch', fontSort, fontSort',+  fontRenderPrepare, fontRenderPrepare', -- configGetFilename, configGetFilename',+  configParseAndLoad, configParseAndLoad', configGetSysRoot, configGetSysRoot',+  configParseAndLoadFromMemory, configParseAndLoadFromMemory',+  configSetSysRoot, configSetSysRoot', configGetFileInfo, configGetFileInfo')+import Graphics.Text.Font.Choose.FontSet (FontSet, FontFaceParser(..))+import Graphics.Text.Font.Choose.FontSet.API (fontSetList, fontSetList',+    fontSetMatch, fontSetMatch', fontSetSort, fontSetSort')+import Graphics.Text.Font.Choose.Init (initLoadConfig, initLoadConfigAndFonts,+    init, fini, reinit, bringUptoDate, version)+import Graphics.Text.Font.Choose.LangSet (LangSet, defaultLangs, langs,+    langSetCompare, langNormalize, langCharSet)+import Graphics.Text.Font.Choose.ObjectSet (ObjectSet)+import Graphics.Text.Font.Choose.Pattern (Pattern(..), Binding(..), equalSubset,+    normalizePattern, filter, defaultSubstitute, nameParse, nameUnparse, format,+    setValue, setValues, unset, getValues, getValues', getValue, getValue', getValue0)+import Graphics.Text.Font.Choose.Range (Range(..), iRange)+import Graphics.Text.Font.Choose.Strings (StrSet, StrList)+import Graphics.Text.Font.Choose.Value (Value(..))+import Graphics.Text.Font.Choose.Weight (weightFromOpenTypeDouble, weightToOpenTypeDouble,+    weightFromOpenType, weightToOpenType)
+ Graphics/Text/Font/Choose/CharSet.hs view
@@ -0,0 +1,81 @@+module Graphics.Text.Font.Choose.CharSet where++import Data.Set (Set, union)+import qualified Data.Set as Set+import Graphics.Text.Font.Choose.Result (throwNull, throwFalse)++import Data.Word (Word32)+import Foreign.Ptr+import Control.Exception (bracket)+import Control.Monad (forM)+import Foreign.Marshal.Alloc (alloca, allocaBytes)+import GHC.Base (unsafeChr)+import Data.Char (ord, isHexDigit)+import Numeric (readHex)++-- | An FcCharSet is a set of Unicode chars.+type CharSet = Set Char++parseChar :: String -> Char+parseChar str | ((x, _):_) <- readHex str = toEnum x+replaceWild ch ('?':rest) = ch:replaceWild ch rest+replaceWild ch (c:cs) = c:replaceWild ch cs+replaceWild _ "" = ""+parseWild ch str = parseChar $ replaceWild ch str+-- | Utility for parsing "unicode-range" @font-face property.+parseCharSet ('U':rest) = parseCharSet ('u':rest) -- lowercase initial "u"+parseCharSet ('u':'+':cs)+    | (start@(_:_), '-':ends) <- span isHexDigit cs,+        (end@(_:_), rest) <- span isHexDigit ends, Just set <- parseCharSet' rest =+            Just $ Set.union set $ Set.fromList [parseChar start..parseChar end]+    | (codepoint@(_:_), rest) <- span isHexDigit cs, Just set <- parseCharSet' rest =+        Just $ flip Set.insert set $ parseChar codepoint+    | (codepoint@(_:_), rest) <- span (\c -> isHexDigit c || c == '?') cs,+        Just set <- parseCharSet' rest =+            Just $ Set.union set $ Set.fromList [+                parseWild '0' codepoint..parseWild 'f' codepoint]+parseCharSet _ = Nothing+parseCharSet' (',':rest) = parseCharSet rest+parseCharSet' "" = Just Set.empty+parseCharSet' _ = Nothing++------+--- Low-level+------++data CharSet'+type CharSet_ = Ptr CharSet'++withNewCharSet :: (CharSet_ -> IO a) -> IO a+withNewCharSet cb = bracket (throwNull <$> fcCharSetCreate) fcCharSetDestroy cb+foreign import ccall "FcCharSetCreate" fcCharSetCreate :: IO CharSet_+foreign import ccall "FcCharSetDestroy" fcCharSetDestroy :: CharSet_ -> IO ()++withCharSet :: CharSet -> (CharSet_ -> IO a) -> IO a+withCharSet chars cb = withNewCharSet $ \chars' -> do+    forM (Set.elems chars) $ \ch' ->+        throwFalse <$> (fcCharSetAddChar chars' $ fromIntegral $ ord ch')+    cb chars'+foreign import ccall "FcCharSetAddChar" fcCharSetAddChar :: CharSet_ -> Word32 -> IO Bool++thawCharSet :: CharSet_ -> IO CharSet+thawCharSet chars' = allocaBytes fcCHARSET_MAP_SIZE $ \iter' -> alloca $ \next' -> do+    first <- fcCharSetFirstPage chars' iter' next'+    let go = do {+        ch <- fcCharSetNextPage chars' iter' next';+        if ch == maxBound then return []+        else do+            chs <- go+            return (ch:chs)+      }+    if first == maxBound then return Set.empty else do+        rest <- go+        return $ Set.fromList $ map (unsafeChr . fromIntegral) (first:rest)+foreign import ccall "FcCharSetFirstPage" fcCharSetFirstPage ::+    CharSet_ -> Ptr Word32 -> Ptr Word32 -> IO Word32+foreign import ccall "FcCharSetNextPage" fcCharSetNextPage ::+    CharSet_ -> Ptr Word32 -> Ptr Word32 -> IO Word32+foreign import ccall "my_FcCHARSET_MAP_SIZE" fcCHARSET_MAP_SIZE :: Int++thawCharSet_ :: IO CharSet_ -> IO CharSet+thawCharSet_ cb = bracket (throwNull <$> cb) fcCharSetDestroy thawCharSet
+ Graphics/Text/Font/Choose/Config.hs view
@@ -0,0 +1,405 @@+module Graphics.Text.Font.Choose.Config where++import Graphics.Text.Font.Choose.Strings+import Graphics.Text.Font.Choose.FontSet+import Graphics.Text.Font.Choose.CharSet+import Graphics.Text.Font.Choose.Pattern+import Graphics.Text.Font.Choose.ObjectSet++import Foreign.ForeignPtr+import Foreign.Ptr (Ptr, nullPtr, FunPtr)+import Foreign.Marshal.Alloc (alloca, allocaBytes, free)+import Foreign.Storable (Storable(..))+import Foreign.C.String (CString, peekCString, withCString)+import System.IO.Unsafe (unsafePerformIO)++import Control.Exception (bracket)+import Graphics.Text.Font.Choose.Result (throwNull, throwFalse, throwPtr)++-- | System configuration regarding available fonts.+type Config = ForeignPtr Config'+data Config'+type Config_ = Ptr Config'++-- | Creates an empty configuration.+configCreate :: IO Config+configCreate = newForeignPtr fcConfigDestroy =<< throwNull <$> fcConfigCreate+foreign import ccall "FcConfigCreate" fcConfigCreate :: IO Config_+ptr2config = newForeignPtr fcConfigDestroy+foreign import ccall "&FcConfigDestroy" fcConfigDestroy :: FunPtr (Config_ -> IO ())++-- | Sets the current default configuration to config.+-- Implicitly calls `configBuildFonts` if necessary.+configSetCurrent :: Config -> IO ()+configSetCurrent config = throwFalse =<< (withForeignPtr config $ fcConfigSetCurrent)+foreign import ccall "FcConfigSetCurrent" fcConfigSetCurrent :: Config_ -> IO Bool++-- | Returns the current default configuration.+configGetCurrent :: IO Config+configGetCurrent = (throwNull <$> fcConfigReference nullPtr) >>=+    newForeignPtr fcConfigDestroy+foreign import ccall "FcConfigReference" fcConfigReference :: Config_ -> IO Config_++-- | Checks all of the files related to config and returns whether any of them+-- has been modified since the configuration was created.+configUptoDate :: Config -> IO Bool+configUptoDate config = withForeignPtr config $ fcConfigUptoDate+foreign import ccall "FcConfigUptoDate" fcConfigUptoDate :: Config_ -> IO Bool++-- | Return the current user's home directory, if it is available,+-- and if using it is enabled, and NULL otherwise. (See also `configEnableHome`).+configHome :: IO (Maybe String)+configHome = do+    ret <- fcConfigHome+    if ret == nullPtr then return Nothing else Just <$> peekCString ret+foreign import ccall "FcConfigHome" fcConfigHome :: IO CString++-- | If enable is `True`, then Fontconfig will use various files which are+-- specified relative to the user's home directory (using the ~ notation in+-- the configuration). When enable is `False`, then all use of the home+-- directory in these contexts will be disabled. The previous setting of+-- the value is returned.+foreign import ccall "FcConfigEnableHome" configEnableHome :: Bool -> IO Bool++-- | Returns the list of font directories specified in the configuration files+-- for config. Does not include any subdirectories.+configBuildFonts :: Config -> IO ()+configBuildFonts config = throwFalse =<< (withForeignPtr config $ fcConfigBuildFonts)+-- | Variant of `configBuildFonts` operating on the current configuration.+configBuildFonts' :: IO ()+configBuildFonts' = throwFalse =<< fcConfigBuildFonts nullPtr+foreign import ccall "FcConfigBuildFonts" fcConfigBuildFonts :: Config_ -> IO Bool++-- | Returns the list of font directories specified in the configuration files+-- for config. Does not include any subdirectories.+configGetConfigDirs :: Config -> IO StrList+configGetConfigDirs = configStrsFunc fcConfigGetConfigDirs+-- | Variant of `configGetConfigDirs` which operates on the current configuration.+configGetConfigDirs' :: IO StrList+configGetConfigDirs' = thawStrList =<< fcConfigGetConfigDirs nullPtr+foreign import ccall "FcConfigGetConfigDirs" fcConfigGetConfigDirs :: Config_ -> IO StrList_++-- | Returns the list of font directories in config.+-- This includes the configured font directories along with any directories+-- below those in the filesystem.+configGetFontDirs :: Config -> IO StrList+configGetFontDirs = configStrsFunc fcConfigGetFontDirs+-- | Variant of `configGetFontDirs` which operates on the current config.+configGetFontDirs' :: IO StrList+configGetFontDirs' = thawStrList_ $ fcConfigGetFontDirs nullPtr+foreign import ccall "FcConfigGetFontDirs" fcConfigGetFontDirs :: Config_ -> IO StrList_++-- | Returns the list of known configuration files used to generate config.+configGetConfigFiles :: Config -> IO StrList+configGetConfigFiles = configStrsFunc fcConfigGetConfigFiles+-- | Variant of `configGetConfigFiles` which operates upon current configuration.+configGetConfigFiles' :: IO StrList+configGetConfigFiles' = thawStrList_ $ fcConfigGetConfigFiles nullPtr+foreign import ccall "FcConfigGetConfigFiles" fcConfigGetConfigFiles :: Config_ -> IO StrList_++-- | Returns a string list containing all of the directories that fontconfig+-- will search when attempting to load a cache file for a font directory.+configGetCacheDirs :: Config -> IO StrList+configGetCacheDirs = configStrsFunc fcConfigGetCacheDirs+-- | Variant of `configGetCacheDirs` which operates upon current configuration.+configGetCacheDirs' :: IO StrList+configGetCacheDirs' = thawStrList_ $ fcConfigGetCacheDirs nullPtr+foreign import ccall "FcConfigGetCacheDirs" fcConfigGetCacheDirs :: Config_ -> IO StrList_++-- | Whether to operate upon system or application fontlists.+data SetName = SetSystem | SetApplication deriving (Enum, Eq, Show, Read)+-- | Returns one of the two sets of fonts from the configuration as specified+-- by set. This font set is owned by the library and must not be modified or+-- freed. If config is NULL, the current configuration is used.+-- This function isn't MT-safe.+configGetFonts :: Config -> SetName -> IO FontSet+configGetFonts config set = do+    ret <- withForeignPtr config $ flip fcConfigGetFonts $ fromEnum set+    thawFontSet $ throwNull ret+-- | Variant of `configGetFonts` which operates upon current configuration.+configGetFonts' :: SetName -> IO FontSet+configGetFonts' set = do+    ret <- fcConfigGetFonts nullPtr $ fromEnum set+    thawFontSet $ throwNull ret+foreign import ccall "FcConfigGetFonts" fcConfigGetFonts :: Config_ -> Int -> IO FontSet_++-- | Returns the interval between automatic checks of the configuration+-- (in seconds) specified in config. The configuration is checked during+-- a call to FcFontList when this interval has passed since the last check.+-- An interval setting of zero disables automatic checks.+configGetRescanInterval :: Config -> IO Int+configGetRescanInterval = flip withForeignPtr $ fcConfigGetRescanInterval+-- | Variant of `configGetRescanInterval` which operates upon current configuration.+configGetRescanInterval' :: IO Int+configGetRescanInterval' = fcConfigGetRescanInterval nullPtr+foreign import ccall "FcConfigGetRescanInterval" fcConfigGetRescanInterval ::+    Config_ -> IO Int++-- | Sets the rescan interval.+-- An interval setting of zero disables automatic checks.+configSetRescanInterval :: Config -> Int -> IO ()+configSetRescanInterval config val =+    throwFalse =<< (withForeignPtr config $ flip fcConfigSetRescanInterval val)+-- | Variant of `configSetRescanInterval` which operates upon current configuration.+configSetRescanInterval' :: Int -> IO ()+configSetRescanInterval' v = throwFalse =<< fcConfigSetRescanInterval nullPtr v+foreign import ccall "FcConfigSetRescanInterval" fcConfigSetRescanInterval ::+    Config_ -> Int -> IO Bool++-- | Adds an application-specific font to the configuration.+configAppFontAddFile :: Config -> String -> IO ()+configAppFontAddFile config file = throwFalse =<<+    (withForeignPtr config $ \config' -> withCString file $ \file' ->+        fcConfigAppFontAddFile config' file')+-- | Variant of `configAppFontAddFile` which operates upon current configuration.+configAppFontAddFile' :: String -> IO ()+configAppFontAddFile' file =+    throwFalse =<< (withCString file $ fcConfigAppFontAddFile nullPtr)+foreign import ccall "FcConfigAppFontAddFile" fcConfigAppFontAddFile ::+    Config_ -> CString -> IO Bool++-- | Scans the specified directory for fonts,+-- adding each one found to the application-specific set of fonts.+configAppFontAddDir :: Config -> String -> IO ()+configAppFontAddDir config file = throwFalse =<<+    (withForeignPtr config $ \config' -> withCString file $ fcConfigAppFontAddDir config')+-- | Variant of `configAppFontAddDir` which operates upon current configuration.+configAppFontAddDir' :: String -> IO ()+configAppFontAddDir' v = throwFalse =<< (withCString v $ fcConfigAppFontAddDir nullPtr)+foreign import ccall "FcConfigAppFontAddDir" fcConfigAppFontAddDir ::+    Config_ -> CString -> IO Bool++-- | Clears the set of application-specific fonts.+configAppFontClear :: Config -> IO ()+configAppFontClear config = throwFalse =<< withForeignPtr config fcConfigAppFontClear+-- | Variant of `configAppFontClear` which operates upon current configuration.+configAppFontClear' :: IO ()+configAppFontClear' = throwFalse =<< fcConfigAppFontClear nullPtr+foreign import ccall "FcConfigAppFontClear" fcConfigAppFontClear :: Config_ -> IO Bool++-- | What purpose does the given pattern serve?+data MatchKind = MatchPattern | MatchFont | MatchScan deriving Enum+-- | Performs the sequence of pattern modification operations,+-- if kind is `MatchPattern`, then those tagged as pattern operations are applied,+-- else if kind is `MatchFont`, those tagged as font operations are applied and+-- p_pat is used for <test> elements with target=pattern.+configSubstituteWithPat :: Config -> Pattern -> Pattern -> MatchKind -> Pattern+configSubstituteWithPat config p p_pat kind = unsafePerformIO $+    withForeignPtr config $ \config' -> withPattern p $ \p' ->+        withPattern p_pat $ \p_pat' -> do+            ok <- fcConfigSubstituteWithPat config' p' p_pat' $ fromEnum kind+            throwFalse ok+            thawPattern p'+-- | Variant of `configSubstituteWithPat` which operates upon current configuration.+configSubstituteWithPat' :: Pattern -> Pattern -> MatchKind -> Pattern+configSubstituteWithPat' p p_pat kind = unsafePerformIO $+    withPattern p $ \p' -> withPattern p_pat $ \p_pat' -> do+        ok <- fcConfigSubstituteWithPat nullPtr p' p_pat' $ fromEnum kind+        throwFalse ok+        thawPattern p'+foreign import ccall "FcConfigSubstituteWithPat" fcConfigSubstituteWithPat ::+    Config_ -> Pattern_ -> Pattern_ -> Int -> IO Bool++-- | Calls FcConfigSubstituteWithPat without setting p_pat.+configSubstitute :: Config -> Pattern -> MatchKind -> Pattern+configSubstitute config p kind = unsafePerformIO $+    withForeignPtr config $ \config' -> withPattern p $ \p' -> do+        ok <- fcConfigSubstitute config' p' $ fromEnum kind+        throwFalse ok+        thawPattern p'+-- | Variant `configSubstitute` which operates upon current configuration.+configSubstitute' :: Pattern -> MatchKind -> Pattern+configSubstitute' p kind = unsafePerformIO $ withPattern p $ \p' -> do+    ok <- fcConfigSubstitute nullPtr p' $ fromEnum kind+    throwFalse ok+    thawPattern p'+foreign import ccall "FcConfigSubstitute" fcConfigSubstitute ::+    Config_ -> Pattern_ -> Int -> IO Bool++-- | Finds the font in sets most closely matching pattern and returns+-- the result of `fontRenderPrepare` for that font and the provided pattern.+-- This function should be called only after `configSubstitute` and+-- `defaultSubstitute` have been called for p;+-- otherwise the results will not be correct.+fontMatch :: Config -> Pattern -> Maybe Pattern+fontMatch config pattern = unsafePerformIO $ withForeignPtr config $ \config' ->+    withPattern pattern $ \pattern' -> alloca $ \res' -> do+        ret <- fcFontMatch config' pattern' res'+        throwPtr res' $ thawPattern_ $ pure ret+-- | Variant of `fontMatch` which operates upon current configuration.+fontMatch' :: Pattern -> Maybe Pattern+fontMatch' pattern = unsafePerformIO $ withPattern pattern $ \pattern' -> alloca $ \res' -> do+    ret <- fcFontMatch nullPtr pattern' res'+    throwPtr res' $ thawPattern_ $ pure ret+foreign import ccall "FcFontMatch" fcFontMatch ::+    Config_ -> Pattern_ -> Ptr Int -> IO Pattern_++-- | Returns the list of fonts sorted by closeness to p. If trim is `True`,+-- elements in the list which don't include Unicode coverage not provided by+-- earlier elements in the list are elided. The union of Unicode coverage of+-- all of the fonts is returned in `snd`. This function should be called only+-- after `configSubstitute` and `defaultSubstitute` have been called for p;+-- otherwise the results will not be correct.+fontSort :: Config -> Pattern -> Bool -> Maybe (FontSet, CharSet)+fontSort config pattern trim = unsafePerformIO $ withForeignPtr config $ \config' ->+    withPattern pattern $ \pattern' -> withNewCharSet $ \csp' -> alloca $ \res' -> do+        ret <- fcFontSort config' pattern' trim csp' res'+        throwPtr res' $ do+            x <- thawFontSet_ $ pure $ throwNull ret+            y <- thawCharSet $ throwNull csp'+            return (x, y)+-- | Variant of `fontSort` which operates upon current configuration.+fontSort' :: Pattern -> Bool -> Maybe (FontSet, CharSet)+fontSort' pattern trim = unsafePerformIO $ withPattern pattern $ \pattern' ->+    withNewCharSet $ \csp' -> alloca $ \res' -> do+        ret <- fcFontSort nullPtr pattern' trim csp' res'+        throwPtr res' $ do+            x <- thawFontSet_ $ pure $ throwNull ret+            y <- thawCharSet $ throwNull csp'+            return (x, y)+foreign import ccall "FcFontSort" fcFontSort ::+    Config_ -> Pattern_ -> Bool -> CharSet_ -> Ptr Int -> IO FontSet_++-- | Creates a new pattern consisting of elements of font not appearing in pat,+-- elements of pat not appearing in font and the best matching value from pat+-- for elements appearing in both. The result is passed to+--`configSubstituteWithPat` with kind `matchFont` and then returned.+fontRenderPrepare :: Config -> Pattern -> Pattern -> Pattern+fontRenderPrepare config pat font = unsafePerformIO $ withForeignPtr config $ \config' ->+    withPattern pat $ \pat' -> withPattern font $ \font' -> do+        ret <- fcFontRenderPrepare config' pat' font'+        thawPattern_ $ pure $ throwNull ret+-- | Variant of `fontRenderPrepare` which operates upon current configuration.+fontRenderPrepare' :: Pattern -> Pattern -> Pattern+fontRenderPrepare' pat font = unsafePerformIO $ withPattern pat $ \pat' ->+    withPattern font $ \font' -> do+        ret <- fcFontRenderPrepare nullPtr pat' font'+        thawPattern_ $ pure ret+foreign import ccall "FcFontRenderPrepare" fcFontRenderPrepare ::+    Config_ -> Pattern_ -> Pattern_ -> IO Pattern_++-- | Selects fonts matching p, creates patterns from those fonts containing only+-- the objects in os and returns the set of unique such patterns.+fontList :: Config -> Pattern -> ObjectSet -> FontSet+fontList config p os = unsafePerformIO $ withForeignPtr config $ \config' ->+    withPattern p $ \p' -> withObjectSet os $ \os' -> do+        ret <- fcFontList config' p' os'+        thawFontSet_ $ pure ret+-- | Variant of `fontList` which operates upon current configuration.+fontList' :: Pattern -> ObjectSet -> FontSet+fontList' p os = unsafePerformIO $ withPattern p $ \p' -> withObjectSet os $ \os' -> do+    ret <- fcFontList nullPtr p' os'+    thawFontSet_ $ pure ret+foreign import ccall "FcFontList" fcFontList ::+    Config_ -> Pattern_ -> ObjectSet_ -> IO FontSet_++{-configGetFilename :: Config -> String -> String+configGetFilename config name = unsafePerformIO $ withForeignPtr config $ \config' ->+    withCString name $ \name' -> do+        ret <- fcConfigGetFilename config' name'+        peekCString' ret+configGetFilename' :: String -> String+configGetFilename' name = unsafePerformIO $ withCString name $ \name' -> do+    ret <- fcConfigGetFilename nullPtr name'+    peekCString' ret+foreign import ccall "FcConfigGetFilename" fcConfigGetFilename :: Config_ -> CString -> IO CString+peekCString' txt = bracket (pure $ throwNull txt) free peekCString-}++-- | Walks the configuration in 'file' and constructs the internal representation+-- in 'config'. Any include files referenced from within 'file' will be loaded+-- and parsed. If 'complain' is `False`, no warning will be displayed if 'file'+-- does not exist. Error and warning messages will be output to stderr. +configParseAndLoad :: Config -> String -> Bool -> IO Bool+configParseAndLoad config name complain = withForeignPtr config $ \config' ->+    withCString name $ \name' -> fcConfigParseAndLoad config' name' complain+-- Variant of `configParseAndLoad` which operates upon current configuration.+configParseAndLoad' :: String -> Bool -> IO Bool+configParseAndLoad' name complain =+    withCString name $ \name' -> fcConfigParseAndLoad nullPtr name' complain+foreign import ccall "FcConfigParseAndLoad" fcConfigParseAndLoad ::+    Config_ -> CString -> Bool -> IO Bool++-- | Walks the configuration in 'memory' and constructs the internal representation+-- in 'config'. Any includes files referenced from within 'memory' will be loaded+-- and dparsed. If 'complain' is `False`, no warning will be displayed if 'file'+-- does not exist. Error and warning messages will be output to stderr.+configParseAndLoadFromMemory :: Config -> String -> Bool -> IO Bool+configParseAndLoadFromMemory config buffer complain = withForeignPtr config $ \config' ->+    withCString buffer $ \buffer' ->+        fcConfigParseAndLoadFromMemory config' buffer' complain+-- | Variant of `configParseAndLoadFromMemory` which operates upon current+-- configuration.+configParseAndLoadFromMemory' :: String -> Bool -> IO Bool+configParseAndLoadFromMemory' buffer complain = withCString buffer $ \buffer' ->+    fcConfigParseAndLoadFromMemory nullPtr buffer' complain+foreign import ccall "FcConfigParseAndLoadFromMemory" fcConfigParseAndLoadFromMemory ::+    Config_ -> CString -> Bool -> IO Bool++-- | Obtains the system root directory in 'config' if available.+-- All files (including file properties in patterns) obtained from this 'config'+-- are relative to this system root directory.+-- This function isn't MT-safe. +configGetSysRoot :: Config -> IO String+configGetSysRoot = flip withForeignPtr $ \config' -> do+    ret <- fcConfigGetSysRoot config'+    peekCString $ throwNull ret+-- | Variant of `configGetSysRoot` which operates upon current configuration.+configGetSysRoot' :: IO String+configGetSysRoot' = (peekCString .throwNull) =<< fcConfigGetSysRoot nullPtr+foreign import ccall "FcConfigGetSysRoot" fcConfigGetSysRoot :: Config_ -> IO CString++-- | Set 'sysroot' as the system root directory. All file paths used or created+-- with this 'config' (including file properties in patterns) will be considered+-- or made relative to this 'sysroot'. This allows a host to generate caches for+-- targets at build time. This also allows a cache to be re-targeted to a+-- different base directory if 'configGetSysRoot' is used to resolve file paths.+-- When setting this on the current config this causes changing current config.+configSetSysRoot :: Config -> String -> IO ()+configSetSysRoot config val = withForeignPtr config $ \config' -> withCString val $+    fcConfigSetSysRoot config'+-- | Variant of `configSetSysRoot` which operates upon current configuration.+configSetSysRoot' :: String -> IO ()+configSetSysRoot' val = withCString val $ fcConfigSetSysRoot nullPtr+foreign import ccall "FcConfigSetSysRoot" fcConfigSetSysRoot :: Config_ -> CString -> IO ()++-- | Retrieves a list of all filepaths & descriptions for all fonts in this+-- configuration alongside whether each is enabled.+-- Not thread-safe.+configGetFileInfo :: Config -> IO [(FilePath, String, Bool)]+configGetFileInfo config =+  withForeignPtr config $ \config' -> allocaBytes configFileInfoIter'Size $ \iter' -> do+    fcConfigFileInfoIterInit config' iter'+    let readEnt = alloca $ \name' -> alloca $ \description' -> alloca $ \enabled' -> do {+        ok <- fcConfigFileInfoIterGet config' iter' name' description' enabled';+        if ok then do+            name <- peekCString =<< peek name'+            description <- peekCString =<< peek description'+            enabled <- peek enabled'+            return $ Just (name, description, enabled)+        else return Nothing}+    let go = do {+        ent' <- readEnt;+        case ent' of+            Just ent -> do+                ok <- fcConfigFileInfoIterNext config' iter'+                ents <- if ok then go else return []+                return (ent : ents)+            Nothing -> return []}+    go+-- | Variant `configGetFileInfo` which operates upon current configuration.+configGetFileInfo' :: IO [(FilePath, String, Bool)]+configGetFileInfo' = configGetCurrent >>= configGetFileInfo+data ConfigFileInfoIter'+foreign import ccall "size_ConfigFileInfoIter" configFileInfoIter'Size :: Int+type ConfigFileInfoIter_ = Ptr ConfigFileInfoIter'+foreign import ccall "FcConfigFileInfoIterInit" fcConfigFileInfoIterInit ::+    Config_ -> ConfigFileInfoIter_ -> IO ()+foreign import ccall "FcConfigFileInfoIterNext" fcConfigFileInfoIterNext ::+    Config_ -> ConfigFileInfoIter_ -> IO Bool+foreign import ccall "FcConfigFileInfoIterGet" fcConfigFileInfoIterGet ::+    Config_ -> ConfigFileInfoIter_ -> Ptr CString -> Ptr CString -> Ptr Bool -> IO Bool++------++configStrsFunc :: (Config_ -> IO StrList_) -> Config -> IO StrList+configStrsFunc cb config = thawStrList_ $ withForeignPtr config cb
+ Graphics/Text/Font/Choose/FontSet.hs view
@@ -0,0 +1,149 @@+{-# LANGUAGE OverloadedStrings #-}+module Graphics.Text.Font.Choose.FontSet where++import Graphics.Text.Font.Choose.Pattern+import Graphics.Text.Font.Choose.Result (throwFalse, throwNull)++import Foreign.Ptr (Ptr, castPtr, nullPtr)+import Foreign.Storable (pokeElemOff, sizeOf)+import Foreign.Marshal.Alloc (allocaBytes)+import Foreign.Marshal.Array (peekArray)+import Control.Monad (forM)+import Control.Exception (bracket)++-- For CSS bindings+import Stylist.Parse (StyleSheet(..), parseProperties)+import Data.CSS.Syntax.Tokens (Token(..), serialize)+import Data.Text (unpack, Text)+import Graphics.Text.Font.Choose.Range (iRange)+import Graphics.Text.Font.Choose.CharSet (parseCharSet)+import Data.List (intercalate)++-- | An `FontSet` contains a list of `Pattern`s.+-- Internally fontconfig uses this data structure to hold sets of fonts.+-- Externally, fontconfig returns the results of listing fonts in this format.+type FontSet = [Pattern]++------+--- Low-level+------+data FontSet'+type FontSet_ = Ptr FontSet'++withNewFontSet :: (FontSet_ -> IO a) -> IO a+withNewFontSet = bracket fcFontSetCreate fcFontSetDestroy+foreign import ccall "FcFontSetCreate" fcFontSetCreate :: IO FontSet_+foreign import ccall "FcFontSetDestroy" fcFontSetDestroy :: FontSet_ -> IO ()++withFontSet :: FontSet -> (FontSet_ -> IO a) -> IO a+withFontSet fonts cb = withNewFontSet $ \fonts' -> do+    forM fonts $ \font -> do+        font' <- patternAsPointer font+        throwFalse <$> fcFontSetAdd fonts' font'+    cb fonts'+foreign import ccall "FcFontSetAdd" fcFontSetAdd :: FontSet_ -> Pattern_ -> IO Bool++withFontSets :: [FontSet] -> (Ptr FontSet_ -> Int -> IO a) -> IO a+withFontSets fontss cb = let n = length fontss in+    allocaBytes (sizeOf (undefined :: FontSet_) * n) $ \fontss' ->+        withFontSets' fontss 0 fontss' $ cb fontss' n+withFontSets' :: [FontSet] -> Int -> Ptr FontSet_ -> IO a -> IO a+withFontSets' [] _ _ cb = cb+withFontSets' (fonts:fontss) i fontss' cb = withFontSet fonts $ \fonts' -> do+    pokeElemOff fontss' i fonts'+    withFontSets' fontss (succ i) fontss' cb++thawFontSet :: FontSet_ -> IO FontSet+thawFontSet fonts' = do+    -- Very hacky, but these debug statements must be in here to avoid segfaults.+    -- FIXME: Is there an alternative?+    print "a"+    n <- get_fontSet_nfont fonts'+    print "b"+    if n == 0 then return []+    else do+        print "c"+        ret <- forM [0..pred n] (thawPattern_ . get_fontSet_font fonts')+        print "d"+        return ret+foreign import ccall "get_fontSet_nfont" get_fontSet_nfont :: FontSet_ -> IO Int+foreign import ccall "get_fontSet_font" get_fontSet_font :: FontSet_ -> Int -> IO Pattern_++thawFontSet_ :: IO FontSet_ -> IO FontSet+thawFontSet_ cb = bracket (throwNull <$> cb) fcFontSetDestroy thawFontSet++------+--- CSS Bindings+------++-- | `StyleSheet` wrapper to parse @font-face rules.+data FontFaceParser a = FontFaceParser { cssFonts :: FontSet, cssInner :: a}++parseFontFaceSrc (Function "local":Ident name:RightParen:Comma:rest) =+    ("local:" ++ unpack name):parseFontFaceSrc rest+parseFontFaceSrc (Function "local":String name:RightParen:Comma:rest) =+    ("local:" ++ unpack name):parseFontFaceSrc rest+parseFontFaceSrc (Function "local":Ident name:RightParen:[]) = ["local:" ++ unpack name]+parseFontFaceSrc (Function "local":String name:RightParen:[]) = ["local:" ++ unpack name]++parseFontFaceSrc (Url link:toks)+    | Comma:rest <- skipMeta toks = unpack link:parseFontFaceSrc rest+    | [] <- skipMeta toks = [unpack link]+    | otherwise = [""] -- Error indicator!+  where+    skipMeta (Function "format":Ident _:RightParen:rest) = skipMeta rest+    skipMeta (Function "format":String _:RightParen:rest) = skipMeta rest+    skipMeta (Function "tech":Ident _:RightParen:rest) = skipMeta rest+    skipMeta (Function "tech":String _:RightParen:rest) = skipMeta rest+    skipMeta toks = toks++parseFontFaceSrc _ = [""]++properties2font :: [(Text, [Token])] -> Pattern+properties2font (("font-family", [String font]):props) =+    setValue "family" Strong (unpack font) $ properties2font props+properties2font (("font-family", [Ident font]):props) =+    setValue "family" Strong (unpack font) $ properties2font props++properties2font (("font-stretch", [tok]):props) | Just x <- parseFontStretch tok =+    setValue "width" Strong x $ properties2font props+properties2font (("font-stretch", [start, end]):props)+    | Just x <- parseFontStretch start, Just y <- parseFontStretch end =+        setValue "width" Strong (x `iRange` y) $ properties2font props++properties2font (("font-weight", [tok]):props) | Just x <- parseFontWeight tok =+    setValue "width" Strong x $ properties2font props+properties2font (("font-weight", [start, end]):props)+    | Just x <- parseFontStretch start, Just y <- parseFontStretch end =+        setValue "weight" Strong (x `iRange` y) $ properties2font props++properties2font (("font-feature-settings", toks):props)+    | (features, True, []) <- parseFontFeatures toks =+        setValue "fontfeatures" Strong (intercalate "," $ map fst features) $+            properties2font props++properties2font (("font-variation-settings", toks):props)+    | (_, True, []) <- parseFontVars toks =+        setValue "variable" Strong True $ properties2font props++properties2font (("unicode-range", toks):props)+    | Just chars <- parseCharSet $ unpack $ serialize toks =+        setValue "charset" Strong chars $ properties2font props++-- Ignoring metadata & trusting in FreeType's broad support for fonts.+properties2font (("src", toks):props)+    | fonts@(_:_) <- parseFontFaceSrc toks, "" `notElem` fonts =+        setValue "web-src" Strong (intercalate "\t" fonts) $ properties2font props++properties2font (_:props) = properties2font props+properties2font [] = []++instance StyleSheet a => StyleSheet (FontFaceParser a) where+    setPriorities v (FontFaceParser x self) = FontFaceParser x $ setPriorities v self+    addRule (FontFaceParser x self) rule = FontFaceParser x $ addRule self rule++    addAtRule (FontFaceParser fonts self) "font-face" toks =+        let ((props, _), toks') = parseProperties toks+        in (FontFaceParser (properties2font props:fonts) self, toks')+    addAtRule (FontFaceParser x self) key toks =+        let (a, b) = addAtRule self key toks in (FontFaceParser x a, b)
+ Graphics/Text/Font/Choose/FontSet/API.hs view
@@ -0,0 +1,77 @@+-- Here to break recursive imports...+module Graphics.Text.Font.Choose.FontSet.API where++import Graphics.Text.Font.Choose.FontSet+import Graphics.Text.Font.Choose.Pattern+import Graphics.Text.Font.Choose.Config+import Graphics.Text.Font.Choose.ObjectSet+import Graphics.Text.Font.Choose.CharSet+import Graphics.Text.Font.Choose.Result (throwPtr)++import Foreign.Ptr (Ptr, castPtr, nullPtr)+import Foreign.ForeignPtr (withForeignPtr)+import Foreign.Marshal.Alloc (alloca)+import System.IO.Unsafe (unsafePerformIO)++-- | Selects fonts matching pattern from sets,+-- creates patterns from those fonts containing only the objects in object_set+-- and returns the set of unique such patterns.+fontSetList :: Config -> [FontSet] -> Pattern -> ObjectSet -> FontSet+fontSetList config fontss pattern objs = unsafePerformIO $ withForeignPtr config $ \config' ->+    withFontSets fontss $ \fontss' n -> withPattern pattern $ \pattern' ->+        withObjectSet objs $ \objs' ->+            thawFontSet_ $ fcFontSetList config' fontss' n pattern' objs'+-- | Variant of `fontSetList` operating upon register default `Config`.+fontSetList' :: [FontSet] -> Pattern -> ObjectSet -> FontSet+fontSetList' fontss pattern objs = unsafePerformIO $ withFontSets fontss $ \fontss' n ->+    withPattern pattern $ \pattern' -> withObjectSet objs $ \objs' ->+        thawFontSet_ $ fcFontSetList nullPtr fontss' n pattern' objs'+foreign import ccall "FcFontSetList" fcFontSetList ::+    Config_ -> Ptr FontSet_ -> Int -> Pattern_ -> ObjectSet_ -> IO FontSet_++-- | Finds the font in sets most closely matching pattern+-- and returns the result of `fontRenderPrepare` for that font and+-- the provided pattern. This function should be called only after+-- `configSubstitute` and `defaultSubstitute` have been called for pattern;+-- otherwise the results will not be correct.+fontSetMatch :: Config -> [FontSet] -> Pattern -> Maybe Pattern+fontSetMatch config fontss pattern = unsafePerformIO $ withForeignPtr config $ \config' ->+    withFontSets fontss $ \fontss' n -> withPattern pattern $ \pattern' -> +        alloca $ \res' -> do+            ret <- fcFontSetMatch config' fontss' n pattern' res'+            throwPtr res' $ thawPattern_ $ pure ret+-- | Variant of `fontSetMatch` operating upon registered default `Config`.+fontSetMatch' :: [FontSet] -> Pattern -> Maybe Pattern+fontSetMatch' fontss pattern = unsafePerformIO $ withFontSets fontss $ \fontss' n ->+    withPattern pattern $ \pattern' -> alloca $ \res' -> do+        ret <- fcFontSetMatch nullPtr fontss' n pattern' res'+        throwPtr res' $ thawPattern_ $ pure ret+foreign import ccall "FcFontSetMatch" fcFontSetMatch ::+    Config_ -> Ptr FontSet_ -> Int -> Pattern_ -> Ptr Int -> IO Pattern_++-- | Returns the list of fonts from sets sorted by closeness to pattern.+-- If trim is `True`, elements in the list which don't include Unicode coverage+-- not provided by earlier elements in the list are elided.+-- The union of Unicode coverage of all of the fonts is returned in csp.+-- This function should be called only after `configSubstitute` and+-- `defaultSubstitute` have been called for p;+-- otherwise the results will not be correct.+-- The returned FcFontSet references `Pattern` structures which may be shared by+-- the return value from multiple `fontSort` calls, applications cannot modify+-- these patterns. Instead, they should be passed, along with pattern to+-- `fontRenderPrepare` which combines them into a complete pattern.+fontSetSort :: Config -> [FontSet] -> Pattern -> Bool -> CharSet -> Maybe FontSet+fontSetSort config fontss pattern trim csp = unsafePerformIO $+    withForeignPtr config $ \config' -> withFontSets fontss $ \fontss' n ->+        withPattern pattern $ \pattern' -> withCharSet csp $ \csp' -> alloca $ \res' -> do+            ret' <- fcFontSetSort config' fontss' n pattern' trim csp' res'+            throwPtr res' $ thawFontSet_ $ pure ret'+-- | Variant of `fontSetSort` operating upon registered default `Config`.+fontSetSort' :: [FontSet] -> Pattern -> Bool -> CharSet -> Maybe FontSet+fontSetSort' fontss pattern trim csp = unsafePerformIO $+    withFontSets fontss $ \fontss' n -> withPattern pattern $ \pattern' ->+        withCharSet csp $ \csp' -> alloca $ \res' -> do+            ret' <- fcFontSetSort nullPtr fontss' n pattern' trim csp' res'+            throwPtr res' $ thawFontSet_ $ pure ret'+foreign import ccall "FcFontSetSort" fcFontSetSort :: Config_ -> Ptr FontSet_+    -> Int -> Pattern_ -> Bool -> CharSet_ -> Ptr Int -> IO FontSet_
+ Graphics/Text/Font/Choose/Init.hs view
@@ -0,0 +1,44 @@+module Graphics.Text.Font.Choose.Init (Config, initLoadConfig, initLoadConfigAndFonts,+    init, fini, reinit, bringUptoDate, version) where++import Prelude hiding (init)++import Graphics.Text.Font.Choose.Config++-- | Loads the default configuration file and returns the resulting configuration.+-- Does not load any font information.+initLoadConfig = fcInitLoadConfig >>= ptr2config+foreign import ccall "FcInitLoadConfig" fcInitLoadConfig :: IO Config_+-- | Loads the default configuration file and builds information about the available fonts.+-- Returns the resulting configuration.+initLoadConfigAndFonts = fcInitLoadConfigAndFonts >>= ptr2config+foreign import ccall "FcInitLoadConfigAndFonts" fcInitLoadConfigAndFonts :: IO Config_++-- | Initialize fontconfig library+-- Loads the default configuration file and the fonts referenced therein and+-- sets the default configuration to that result.+-- Returns whether this process succeeded or not.+-- If the default configuration has already been loaded,+-- this routine does nothing and returns FcTrue.+foreign import ccall "FcInit" init :: IO Bool+-- | Frees all data structures allocated by previous calls to fontconfig functions.+-- Fontconfig returns to an uninitialized state,+-- requiring a new call to one of the FcInit functions before any other+-- fontconfig function may be called.+foreign import ccall "FcFini" fini :: IO ()+-- | Forces the default configuration file to be reloaded+-- and resets the default configuration. Returns `False` if the configuration+-- cannot be reloaded (due to configuration file errors,+-- allocation failures or other issues) and leaves the existing configuration+-- unchanged. Otherwise returns True.+foreign import ccall "FcInitReinitialize" reinit :: IO Bool+-- | Checks the rescan interval in the default configuration,+-- checking the configuration if the interval has passed and+-- reloading the configuration if when any changes are detected.+-- Returns False if the configuration cannot be reloaded (see FcInitReinitialize).+-- Otherwise returns True.+foreign import ccall "FcInitBringUptoDate" bringUptoDate :: IO Bool++-- | Library version number+-- Returns the version number of the library.+foreign import ccall "FcGetVersion" version :: Int
+ Graphics/Text/Font/Choose/LangSet.hs view
@@ -0,0 +1,107 @@+module Graphics.Text.Font.Choose.LangSet (LangSet, defaultLangs, langs,+    langSetCompare, langNormalize, langCharSet,+    LangSet_, withLangSet, thawLangSet) where++import Data.Set (Set)+import qualified Data.Set as Set+import Graphics.Text.Font.Choose.Strings (thawStrSet, thawStrSet_, StrSet_)+import Graphics.Text.Font.Choose.CharSet (thawCharSet, CharSet_, CharSet)+import Graphics.Text.Font.Choose.Result (throwNull, throwFalse)++import Foreign.Ptr (Ptr)+import Foreign.C.String (CString, withCString, peekCString)+import Foreign.Marshal.Alloc (free)+import Control.Exception (bracket)+import Control.Monad (forM)+import System.IO.Unsafe (unsafePerformIO)++-- | An `LangSet` is a set of language names (each of which include language and+-- an optional territory). They are used when selecting fonts to indicate which+-- languages the fonts need to support. Each font is marked, using language+-- orthography information built into fontconfig, with the set of supported languages.+type LangSet = Set String++-- | Returns a string set of the default languages according to the environment+-- variables on the system. This function looks for them in order of FC_LANG,+-- LC_ALL, LC_CTYPE and LANG then. If there are no valid values in those+-- environment variables, "en" will be set as fallback.+defaultLangs :: IO LangSet+defaultLangs = thawStrSet =<< fcGetDefaultLangs+foreign import ccall "FcGetDefaultLangs" fcGetDefaultLangs :: IO StrSet_++-- | Returns a string set of all known languages.+langs :: LangSet+langs = unsafePerformIO $ thawStrSet_ $ fcGetLangs+foreign import ccall "FcGetLangs" fcGetLangs :: IO StrSet_++-- | Result of language comparisons.+data LangResult = SameLang | DifferentTerritory | DifferentLang+    deriving (Enum, Eq, Read, Show)+-- | `langSetCompare` compares language coverage for ls_a and ls_b.+-- If they share any language and territory pair, returns `SameLang`.+-- If they share a language but differ in which territory that language is for,+-- this function returns `DifferentTerritory`.+-- If they share no languages in common, this function returns `DifferentLang`.+langSetCompare :: LangSet -> LangSet -> LangResult+langSetCompare a b = unsafePerformIO $ withLangSet a $ \a' -> withLangSet b $ \b' ->+    (toEnum <$> fcLangSetCompare a' b')+foreign import ccall "FcLangSetCompare" fcLangSetCompare ::+    LangSet_ -> LangSet_ -> IO Int++-- | `langSetContains` returns FcTrue if ls_a contains every language in ls_b.+-- ls_a will 'contain' a language from ls_b if ls_a has exactly the language,+-- or either the language or ls_a has no territory.+langSetContains :: LangSet -> LangSet -> Bool+langSetContains a b = unsafePerformIO $ withLangSet a $ \a' -> withLangSet b $+    fcLangSetContains a'+foreign import ccall "FcLangSetContains" fcLangSetContains ::+    LangSet_ -> LangSet_ -> IO Bool++-- | FcLangSetHasLang checks whether ls supports lang.+-- If ls has a matching language and territory pair, this function returns+-- `SameLang`. If ls has a matching language but differs in which territory+-- that language is for, this function returns `DifferentTerritory`. If ls has+-- no matching language, this function returns `DifferentLang`.+langSetHasLang :: LangSet -> String -> LangResult+langSetHasLang a b = unsafePerformIO $ withLangSet a $ \a' -> withCString b $ \b' ->+    (toEnum <$> fcLangSetHasLang a' b')+foreign import ccall "FcLangSetHasLang" fcLangSetHasLang :: LangSet_ -> CString -> IO Int++-- | Returns a string to make lang suitable on FontConfig.+langNormalize :: String -> String+langNormalize "" = ""+langNormalize lang = unsafePerformIO $ withCString lang (peekCString_ . fcLangNormalize)+foreign import ccall "FcLangNormalize" fcLangNormalize :: CString -> CString+peekCString_ str' = do+    str <- peekCString $ throwNull str'+    free str'+    return str++-- | Returns the FcCharMap for a language.+langCharSet :: String -> CharSet+langCharSet lang = unsafePerformIO $+    withCString lang (thawCharSet . throwNull . fcLangGetCharSet)+foreign import ccall "FcLangGetCharSet" fcLangGetCharSet :: CString -> CharSet_++------+--- Low-level+------++data LangSet'+type LangSet_ = Ptr LangSet'++withNewLangSet :: (LangSet_ -> IO a) -> IO a+withNewLangSet = bracket (throwNull <$> fcLangSetCreate) fcLangSetDestroy+foreign import ccall "FcLangSetCreate" fcLangSetCreate :: IO LangSet_+foreign import ccall "FcLangSetDestroy" fcLangSetDestroy :: LangSet_ -> IO ()++withLangSet :: LangSet -> (LangSet_ -> IO a) -> IO a+withLangSet langs cb = withNewLangSet $ \langs' -> do+    forM (Set.elems langs) $ flip withCString $ \lang' ->+        throwFalse <$> fcLangSetAdd langs' lang'+    cb langs'+foreign import ccall "FcLangSetAdd" fcLangSetAdd :: LangSet_ -> CString -> IO Bool++thawLangSet :: LangSet_ -> IO LangSet+thawLangSet = thawStrSet_ . fcLangSetGetLangs+foreign import ccall "FcLangSetGetLangs" fcLangSetGetLangs :: LangSet_ -> IO StrSet_
+ Graphics/Text/Font/Choose/ObjectSet.hs view
@@ -0,0 +1,32 @@+module Graphics.Text.Font.Choose.ObjectSet where++import Foreign.Ptr (Ptr)+import Foreign.C.String (CString, withCString)++import Control.Monad (forM)+import Control.Exception (bracket)+import Graphics.Text.Font.Choose.Result (throwFalse, throwNull)++-- | An `ObjectSet` holds a list of pattern property names;+-- it is used to indicate which properties are to be returned in the patterns+-- from `FontList`.+type ObjectSet = [String]++------+--- LowLevel+------+data ObjectSet'+type ObjectSet_ = Ptr ObjectSet'++withObjectSet :: ObjectSet -> (ObjectSet_ -> IO a) -> IO a+withObjectSet objs cb = withNewObjectSet $ \objs' -> do+    forM objs $ \obj -> withCString obj $ \obj' ->+        throwFalse <$> fcObjectSetAdd objs' obj'+    cb objs'+foreign import ccall "FcObjectSetAdd" fcObjectSetAdd ::+    ObjectSet_ -> CString -> IO Bool++withNewObjectSet :: (ObjectSet_ -> IO a) -> IO a+withNewObjectSet = bracket (throwNull <$> fcObjectSetCreate) fcObjectSetDestroy+foreign import ccall "FcObjectSetCreate" fcObjectSetCreate :: IO ObjectSet_+foreign import ccall "FcObjectSetDestroy" fcObjectSetDestroy :: ObjectSet_ -> IO ()
+ Graphics/Text/Font/Choose/Pattern.hs view
@@ -0,0 +1,341 @@+{-# LANGUAGE DeriveGeneric, OverloadedStrings, TypeSynonymInstances, FlexibleInstances #-}+module Graphics.Text.Font.Choose.Pattern (Pattern(..), Binding(..), equalSubset,+    normalizePattern, filter, defaultSubstitute, nameParse, nameUnparse, format,+    Pattern_, withPattern, thawPattern, thawPattern_, patternAsPointer,++    setValue, setValues, unset, getValues, getValues', getValue, getValue', getValue0,+    parseFontFamily, parseFontFeatures, parseFontVars, parseLength,+    parseFontStretch, parseFontWeight) where++import Prelude hiding (filter)+import Data.List (nub)++import Graphics.Text.Font.Choose.Value+import Graphics.Text.Font.Choose.ObjectSet (ObjectSet, ObjectSet_, withObjectSet)+import Data.Hashable (Hashable(..))+import GHC.Generics (Generic)+import Graphics.Text.Font.Choose.Result (throwFalse, throwNull, throwInt)++import Foreign.Ptr (Ptr)+import Foreign.Marshal.Alloc (alloca, allocaBytes, free)+import Foreign.Storable (Storable(..))+import Foreign.C.String (CString, withCString, peekCString)+import Debug.Trace (trace) -- For reporting internal errors!+import System.IO.Unsafe (unsafePerformIO)++import Control.Monad (forM, join)+import Data.Maybe (catMaybes, fromMaybe, mapMaybe)+import Control.Exception (bracket)++-- Imported for CSS bindings+import Data.CSS.Syntax.Tokens (Token(..), NumericValue(..))+import Data.Text (unpack, Text)+import Stylist (PropertyParser(..))+import Data.Scientific (toRealFloat)+import Data.List (intercalate)+import Graphics.Text.Font.Choose.Weight (weightFromOpenType)++-- | An `Pattern`` holds a set of names with associated value lists;+-- each name refers to a property of a font.+-- `Pattern`s are used as inputs to the matching code as well as+-- holding information about specific fonts.+-- Each property can hold one or more values;+-- conventionally all of the same type, although the interface doesn't demand that.+type Pattern = [(String, [(Binding, Value)])]+-- | How important is it to match this property of the Pattern.+data Binding = Strong | Weak | Same deriving (Eq, Ord, Enum, Show, Generic)++instance Hashable Binding where+    hash Strong = 0+    hash Weak = 1+    hash Same = 2++-- | Replaces the values under the given "key" in given "pattern"+-- with given "binding" & "value".+setValue :: ToValue x => String -> Binding -> x -> Pattern -> Pattern+setValue key b value pat = (key, [(b, toValue value)]):unset key pat+-- | Replaces the values under the given "key" in given "pattern"+-- with given "binding" & "value"s.+setValues :: ToValue x => String -> Binding -> [x] -> Pattern -> Pattern+setValues key b values pat = (key, [(b, toValue v) | v <- values]):unset key pat+-- | Retrieves all values in the given pattern under a given key.+getValues :: String -> Pattern -> [Value]+getValues key pat | Just ret <- lookup key pat = map snd ret+    | otherwise = []+-- | Retrieves all values under a given key & coerces to desired `Maybe` type.+getValues' key pat = mapMaybe fromValue $ getValues key pat+-- | Retrieves first value in the given pattern under a given key.+getValue :: String -> Pattern -> Value+getValue key pat | Just ((_, ret):_) <- lookup key pat = ret+    | otherwise = ValueVoid+-- Retrieves first value under a given key & coerces to desired `Maybe` type.+getValue' :: ToValue x => String -> Pattern -> Maybe x+getValue' key pat = fromValue $ getValue key pat+-- Retrieves first value under a given key & coerces to desired type throw+-- or throw `ErrTypeMismatch`+getValue0 :: ToValue x => String -> Pattern -> x+getValue0 key pat = fromValue' $ getValue key pat++-- | Deletes all entries in the given pattern under a given key.+unset key mapping = [(key', val') | (key', val') <- mapping, key' /= key]++-- | Restructures a `Pattern` so each key repeats at most once.+normalizePattern :: Pattern -> Pattern+normalizePattern pat =+    [(key, [val | (key', vals) <- pat, key' == key, val <- vals]) | key <- nub $ map fst pat]++-- | Returns whether pa and pb have exactly the same values for all of the objects in os.+equalSubset :: Pattern -> Pattern -> ObjectSet -> Bool+equalSubset a b objs = unsafePerformIO $ withPattern a $ \a' -> withPattern b $ \b' ->+    withObjectSet objs $ fcPatternEqualSubset a' b'+foreign import ccall "FcPatternEqualSubset" fcPatternEqualSubset ::+    Pattern_ -> Pattern_ -> ObjectSet_ -> IO Bool++-- | Returns a new pattern that only has those objects from p that are in os.+-- If os is NULL, a duplicate of p is returned.+filter :: Pattern -> ObjectSet -> Pattern+filter pat objs =+    unsafePerformIO $ withPattern pat $ \pat' -> withObjectSet objs $ \objs' ->+        thawPattern_ $ fcPatternFilter pat' objs'+foreign import ccall "FcPatternFilter" fcPatternFilter ::+    Pattern_ -> ObjectSet_ -> IO Pattern_++-- | Supplies default values for underspecified font patterns:+-- * Patterns without a specified style or weight are set to Medium+-- * Patterns without a specified style or slant are set to Roman+-- * Patterns without a specified pixel size are given one computed from any+-- specified point size (default 12), dpi (default 75) and scale (default 1).+defaultSubstitute :: Pattern -> Pattern+defaultSubstitute pat = unsafePerformIO $ withPattern pat $ \pat' -> do+    ret <- fcDefaultSubstitute pat'+    thawPattern pat'+foreign import ccall "FcDefaultSubstitute" fcDefaultSubstitute :: Pattern_ -> IO ()++-- Is this correct memory management?+-- | Converts name from the standard text format described above into a pattern.+nameParse :: String -> Pattern+nameParse name = unsafePerformIO $ withCString name $ \name' ->+    thawPattern_ $ fcNameParse name'+foreign import ccall "FcNameParse" fcNameParse :: CString -> IO Pattern_++-- | Converts the given pattern into the standard text format described above.+nameUnparse :: Pattern -> String+nameUnparse pat = unsafePerformIO $ withPattern pat $ \pat' ->+    bracket (throwNull <$> fcNameUnparse pat') free peekCString+foreign import ccall "FcNameUnparse" fcNameUnparse :: Pattern_ -> IO CString++-- | Converts given pattern into text described fy given format specifier.+-- See for details: https://www.freedesktop.org/software/fontconfig/fontconfig-devel/fcpatternformat.html+format :: Pattern -> String -> String+format pat fmt =+    unsafePerformIO $ withPattern pat $ \pat' -> withCString fmt $ \fmt' -> do+        bracket (throwNull <$> fcPatternFormat pat' fmt') free peekCString+foreign import ccall "FcPatternFormat" fcPatternFormat ::+    Pattern_ -> CString -> IO CString++------+--- Low-level+------++data Pattern'+type Pattern_ = Ptr Pattern'++withPattern :: Pattern -> (Pattern_ -> IO a) -> IO a+withPattern pat cb = withNewPattern $ \pat' -> do+    forM pat $ \(obj, vals) -> withCString obj $ \obj' -> do+        forM vals $ \(strength, val) -> throwFalse <$> withValue val+            (fcPatternAdd_ pat' obj' (strength == Strong) True)+    cb pat'+-- Does Haskell FFI support unboxed structs? Do I really need to write a C wrapper?+foreign import ccall "my_FcPatternAdd" fcPatternAdd_ ::+    Pattern_ -> CString -> Bool -> Bool -> Value_ -> IO Bool++patternAsPointer :: Pattern -> IO Pattern_+patternAsPointer = flip withPattern $ \ret -> do+    fcPatternReference ret+    return ret+foreign import ccall "FcPatternReference" fcPatternReference :: Pattern_ -> IO ()++data PatternIter'+type PatternIter_ = Ptr PatternIter'+foreign import ccall "size_PatternIter" patIter'Size :: Int+thawPattern :: Pattern_ -> IO Pattern+thawPattern pat' = allocaBytes patIter'Size $ \iter' -> do+    fcPatternIterStart pat' iter'+    ret <- go iter'+    return $ normalizePattern ret+  where+    go :: PatternIter_ -> IO Pattern+    go iter' = do+        ok <- fcPatternIterIsValid pat' iter'+        if ok then do+            x <- thawPattern' pat' iter'+            ok' <- fcPatternIterNext pat' iter'+            xs <- if ok' then go iter' else return []+            return (x : xs)+        else return []+foreign import ccall "FcPatternIterStart" fcPatternIterStart ::+    Pattern_ -> PatternIter_ -> IO ()+foreign import ccall "FcPatternIterIsValid" fcPatternIterIsValid ::+    Pattern_ -> PatternIter_ -> IO Bool+foreign import ccall "FcPatternIterNext" fcPatternIterNext ::+    Pattern_ -> PatternIter_ -> IO Bool++thawPattern' :: Pattern_ -> PatternIter_ -> IO (String, [(Binding, Value)])+thawPattern' pat' iter' = do+    obj <- peekCString =<< throwNull <$> fcPatternIterGetObject pat' iter'+    count <- fcPatternIterValueCount pat' iter'+    values <- forM [0..pred count] $ \i ->+        allocaBytes value'Size $ \val' -> alloca $ \binding' -> do+            res <- fcPatternIterGetValue pat' iter' i val' binding'+            throwInt res $ do+                binding <- peek binding'+                val' <- thawValue val'+                return $ case val' of+                    Just val | binding >= 0 && binding <= 2 -> Just (toEnum binding, val)+                    Just val -> Just (Same, val)+                    Nothing -> Nothing+    return (obj, catMaybes $ map join values)+foreign import ccall "FcPatternIterGetObject" fcPatternIterGetObject ::+    Pattern_ -> PatternIter_ -> IO CString+foreign import ccall "FcPatternIterValueCount" fcPatternIterValueCount ::+    Pattern_ -> PatternIter_ -> IO Int+foreign import ccall "FcPatternIterGetValue" fcPatternIterGetValue ::+    Pattern_ -> PatternIter_ -> Int -> Value_ -> Ptr Int -> IO Int++thawPattern_ cb = bracket (throwNull <$> cb) fcPatternDestroy thawPattern++withNewPattern cb = bracket (throwNull <$> fcPatternCreate) fcPatternDestroy cb+foreign import ccall "FcPatternCreate" fcPatternCreate :: IO Pattern_+foreign import ccall "FcPatternDestroy" fcPatternDestroy :: Pattern_ -> IO ()++------+--- Pattern+------++parseFontFamily :: [Token] -> ([String], Bool, [Token])+parseFontFamily (String font:Comma:tail) = let (fonts, b, tail') = parseFontFamily tail+    in (unpack font:fonts, b, tail')+parseFontFamily (Ident font:Comma:tail) = let (fonts, b, tail') = parseFontFamily tail+    in (unpack font:fonts, b, tail')+parseFontFamily (String font:tail) = ([unpack font], True, tail)+parseFontFamily (Ident font:tail) = ([unpack font], True, tail)+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)+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 toks = ([], False, toks)++parseLength :: Double -> NumericValue -> Text -> Double+parseLength super length unit = convert (nv2double length) unit+  where+    convert = c+    c x "pt" = x -- Unit FontConfig expects!+    c x "pc" = x/6 `c` "in"+    c x "in" = x/72 `c` "pt"+    c x "Q" = x/40 `c` "cm"+    c x "mm" = x/10 `c` "cm"+    c x "cm" = x/2.54 `c` "in"+    c x "px" = x/96 `c` "in" -- Conversion factor during early days of CSS, got entrenched.+    c x "em" = x * super+    c x "%" = x/100 `c` "em"+    c _ _ = 0/0 -- NaN++parseFontStretch :: Token -> Maybe Int -- Result in percentages+parseFontStretch (Percentage _ x) = Just $ fromEnum $ nv2double x+parseFontStretch (Ident "ultra-condensed") = Just 50+parseFontStretch (Ident "extra-condensed") = Just 63 -- 62.5%, but round towards 100%+parseFontStretch (Ident "condensed") = Just 75+parseFontStretch (Ident "semi-condensed") = Just 88 -- 87.5% actually...+parseFontStretch (Ident "normal") = Just 100+parseFontStretch (Ident "initial") = Just 100+parseFontStretch (Ident "semi-expanded") = Just 112 -- 112.5% actually...+parseFontStretch (Ident "expanded") = Just 125+parseFontStretch (Ident "extra-expanded") = Just 150+parseFontStretch (Ident "ultra-expanded") = Just 200+parseFontStretch _ = Nothing++-- Conversion between CSS scale & FontConfig scale is non-trivial, use lookuptable.+parseFontWeight :: Token -> Maybe Int+parseFontWeight (Ident k) | k `elem` ["initial", "normal"] = Just 80+parseFontWeight (Ident "bold") = Just 200+parseFontWeight (Number _ (NVInteger x)) = Just $ weightFromOpenType $ fromEnum x+parseFontWeight _ = Nothing++nv2double (NVInteger x) = fromInteger x+nv2double (NVNumber x) = toRealFloat x++sets a b c d = Just $ setValues a b c d+set a b c d = Just $ setValue a b c d+seti a b c d = Just $ setValue a b (c :: Int) d+unset' a b = Just $ unset a b++getSize pat | ValueDouble x <- getValue "size" pat = x+    | otherwise = 10++instance PropertyParser Pattern where+    temp = []++    longhand _ self "font-family" toks+        | (fonts, True, []) <- parseFontFamily toks = sets "family" Strong fonts self++    -- font-size: initial should be configurable!+    longhand super self "font-size" [Dimension _ x unit]+        | let y = parseLength (getSize super) x unit, not $ isNaN y =+            set "size" Strong y self+    longhand super self "font-size" [Percentage x y] =+        longhand super self "font-size" [Dimension x y "%"]++    longhand _ self "font-style" [Ident "initial"] = seti "slant" Strong 0 self+    longhand _ self "font-style" [Ident "normal"] = seti "slant" Strong 0 self+    longhand _ self "font-style" [Ident "italic"] = seti "slant" Strong 100 self+    longhand _ self "font-style" [Ident "oblique"] = seti "slant" Strong 110 self++    -- Conversion between CSS scale & FontConfig scale is non-trivial, use lookuptable.+    longhand _ self "font-weight" [tok]+        | Just x <- parseFontWeight tok = seti "weight" Strong x self+    longhand super self "font-weight" [Number _ (NVInteger x)]+        | x > 920 = longhand super self "font-weight" [Number "" $ NVInteger 950]+        | otherwise = longhand super self "font-weight" [Number "" $ NVInteger $ (x `div` 100) * 100]+    longhand _ self "font-weight" [Ident "lighter"]+        | ValueInt x <- getValue "weight" self, x > 200 = seti "weight" Strong 200 self+        -- minus 100 adhears to the CSS standard awefully well in this new scale.+        | ValueInt x <- getValue "weight" self = seti "weight" Strong (max (x - 100) 0) self+        | otherwise = seti "weight" Strong 0 self+    longhand _ self "font-weight" [Ident "bolder"]+        | ValueInt x <- getValue "weight" self, x <= 65 = seti "weight" Strong 80 self+        | ValueInt x <- getValue "weight" self, x <= 150 = seti "weight" Strong 200 self+        | ValueInt x <- getValue "weight" self, x < 210 = seti "weight" Strong 210 self+        | ValueInt _ <- getValue "weight" self = Just self -- As bold as it goes...+        | otherwise = seti "weight" Strong 200 self++    longhand _ self "font-feature-settings" [Ident k]+        | k `elem` ["initial", "normal"] = unset' "fontfeatures" self+    longhand _ self "font-feature-settings" toks+        | (features, True, []) <- parseFontFeatures toks =+            set "fontfeatures" Strong (intercalate "," $ map fst features) self++    longhand _ self "font-variation-settings" [Ident k]+        | k `elem` ["initial", "normal"] = unset' "variable" self+    longhand _ self "font-variation-settings" toks+        | (_, True, []) <- parseFontVars toks = set "variable" Strong True self++    longhand _ s "font-stretch" [tok]+        | Just x <- parseFontStretch tok = seti "width" Strong x s++    longhand _ _ _ _ = Nothing
+ Graphics/Text/Font/Choose/Range.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE DeriveGeneric #-}+module Graphics.Text.Font.Choose.Range where++import Foreign.Ptr (Ptr)+import Control.Exception (bracket)+import Foreign.Marshal.Alloc (alloca)+import Foreign.Storable (peek)++import GHC.Generics (Generic)+import Data.Hashable (Hashable)+import Graphics.Text.Font.Choose.Result (throwNull, throwFalse)++-- | Matches a numeric range.+data Range = Range Double Double deriving (Eq, Show, Ord, Generic)+-- | Matches an integral range.+iRange i j = toEnum i `Range` toEnum j++instance Hashable Range++------+--- Low-level+------+data Range'+type Range_ = Ptr Range'++withRange :: Range -> (Range_ -> IO a) -> IO a+withRange (Range i j) = bracket (throwNull <$> fcRangeCreateDouble i j) fcRangeDestroy+foreign import ccall "FcRangeCreateDouble" fcRangeCreateDouble ::+    Double -> Double -> IO Range_+foreign import ccall "FcRangeDestroy" fcRangeDestroy :: Range_ -> IO ()++thawRange :: Range_ -> IO Range+thawRange range' = alloca $ \i' -> alloca $ \j' -> do+    throwFalse <$> fcRangeGetDouble range' i' j'+    i <- peek i'+    j <- peek j'+    return $ Range i j+foreign import ccall "FcRangeGetDouble" fcRangeGetDouble ::+    Range_ -> Ptr Double -> Ptr Double -> IO Bool
+ Graphics/Text/Font/Choose/Result.hs view
@@ -0,0 +1,37 @@+module Graphics.Text.Font.Choose.Result (Result(..), resultFromPointer,+    Error(..), throwResult, throwInt, throwPtr, throwFalse, throwNull) where++import Foreign.Storable (peek)+import Foreign.Ptr (Ptr, nullPtr)+import Control.Exception (throwIO, throw, Exception)++data Result = Match | NoMatch | TypeMismatch | ResultNoId | OutOfMemory+    deriving (Eq, Show, Read, Enum)++resultFromPointer :: Ptr Int -> IO Result+resultFromPointer res = toEnum <$> peek res++data Error = ErrTypeMismatch | ErrResultNoId | ErrOutOfMemory deriving (Eq, Show, Read)+instance Exception Error++throwResult :: Result -> IO a -> IO (Maybe a)+throwResult Match x = Just <$> x+throwResult NoMatch _ = return Nothing+throwResult TypeMismatch _ = throwIO ErrTypeMismatch+throwResult ResultNoId _ = throwIO ErrResultNoId+throwResult OutOfMemory _ = throwIO ErrOutOfMemory++throwInt :: Int -> IO a -> IO (Maybe a)+throwInt = throwResult . toEnum+throwPtr :: Ptr Int -> IO a -> IO (Maybe a)+throwPtr a b = resultFromPointer a >>= flip throwResult b++throwFalse :: Bool -> IO ()+throwFalse True = return ()+throwFalse False = throwIO ErrOutOfMemory+throwFalse' :: IO Bool -> IO ()+throwFalse' = (>>= throwFalse)++throwNull :: Ptr a -> Ptr a+throwNull ptr | ptr == nullPtr = throw ErrOutOfMemory+    | otherwise = ptr
+ Graphics/Text/Font/Choose/Strings.hs view
@@ -0,0 +1,75 @@+module Graphics.Text.Font.Choose.Strings (StrSet, StrSet_, StrList, StrList_,+    withStrSet, withFilenameSet, thawStrSet, thawStrSet_,+    withStrList, thawStrList, thawStrList_) where++import Data.Set (Set)+import qualified Data.Set as Set+import Graphics.Text.Font.Choose.Result (throwNull, throwFalse)++import Foreign.Ptr (Ptr, nullPtr)+import Foreign.C.String (CString, withCString, peekCString)+import Control.Exception (bracket)+import Control.Monad (forM)++-- | Set of strings, as exposed by other FreeType APIs.+type StrSet = Set String++data StrSet'+type StrSet_ = Ptr StrSet'++withNewStrSet :: (StrSet_ -> IO a) -> IO a+withNewStrSet = bracket (throwNull <$> fcStrSetCreate) fcStrSetDestroy+foreign import ccall "FcStrSetCreate" fcStrSetCreate :: IO StrSet_+foreign import ccall "FcStrSetDestroy" fcStrSetDestroy :: StrSet_ -> IO ()++withStrSet :: StrSet -> (StrSet_ -> IO a) -> IO a+withStrSet strs cb = withNewStrSet $ \strs' -> do+    forM (Set.elems strs) $ \str ->+        throwFalse <$> (withCString str $ fcStrSetAdd strs')+    cb strs'+foreign import ccall "FcStrSetAdd" fcStrSetAdd :: StrSet_ -> CString -> IO Bool++withFilenameSet :: StrSet -> (StrSet_ -> IO a) -> IO a+withFilenameSet paths cb = withNewStrSet $ \paths' -> do+    forM (Set.elems paths) $ \path ->+        throwFalse <$> (withCString path $ fcStrSetAddFilename paths')+    cb paths'+foreign import ccall "FcStrSetAddFilename" fcStrSetAddFilename ::+    StrSet_ -> CString -> IO Bool++thawStrSet :: StrSet_ -> IO StrSet+thawStrSet strs = Set.fromList <$> withStrList strs thawStrList++thawStrSet_ :: IO StrSet_ -> IO StrSet+thawStrSet_ cb = bracket (throwNull <$> cb) fcStrSetDestroy thawStrSet++------------++-- | Output string lists from FontConfig.+type StrList = [String]++data StrList'+type StrList_ = Ptr StrList'++withStrList :: StrSet_ -> (StrList_ -> IO a) -> IO a+withStrList strs = bracket (throwNull <$> fcStrListCreate strs) fcStrListDone+foreign import ccall "FcStrListCreate" fcStrListCreate :: StrSet_ -> IO StrList_+foreign import ccall "FcStrListDone" fcStrListDone :: StrList_ -> IO ()++thawStrList :: StrList_ -> IO StrList+thawStrList strs' = do+    fcStrListFirst strs'+    go+  where+    go = do+        item' <- fcStrListNext strs'+        if item' == nullPtr then return []+        else do+            item <- peekCString item'+            items <- go+            return (item : items)+foreign import ccall "FcStrListFirst" fcStrListFirst :: StrList_ -> IO ()+foreign import ccall "FcStrListNext" fcStrListNext :: StrList_ -> IO CString++thawStrList_ :: IO StrList_ -> IO StrList+thawStrList_ cb = bracket (throwNull <$> cb) fcStrListDone thawStrList
+ Graphics/Text/Font/Choose/Value.hs view
@@ -0,0 +1,178 @@+{-# LANGUAGE DeriveGeneric, TypeSynonymInstances, FlexibleInstances #-}+module Graphics.Text.Font.Choose.Value (Value(..), Value_, withValue, thawValue,+    value'Size, ToValue(..)) where++import Linear.Matrix (M22)+import Linear.V2 (V2(..))+import Graphics.Text.Font.Choose.CharSet (CharSet, withCharSet, thawCharSet)+import FreeType.Core.Base (FT_Face(..))+import Graphics.Text.Font.Choose.LangSet (LangSet, withLangSet, thawLangSet)+import Graphics.Text.Font.Choose.Range (Range, withRange, thawRange)+import Control.Exception (throw)++import Foreign.Ptr (Ptr, castPtr)+import Foreign.Storable (Storable(..))+import Foreign.Marshal.Array (advancePtr)+import Foreign.Marshal.Alloc (allocaBytes)+import Foreign.C.String (withCString, peekCString)++import GHC.Generics (Generic)+import Data.Hashable (Hashable)+import Graphics.Text.Font.Choose.Result (throwNull, Error(ErrTypeMismatch))++-- | A dynamic type system for `Pattern`s.+data Value = ValueVoid+    | ValueInt Int+    | ValueDouble Double+    | ValueString String+    | ValueBool Bool+    | ValueMatrix (M22 Double)+    | ValueCharSet CharSet+    | ValueFTFace FT_Face+    | ValueLangSet LangSet+    | ValueRange Range deriving (Eq, Show, Ord, Generic)++instance Hashable Value++-- | Coerces compiletime types to runtime types.+class ToValue x where+    toValue :: x -> Value+    fromValue :: Value -> Maybe x+    fromValue' :: Value -> x -- throws Result.Error+    fromValue' self | Just ret <- fromValue self = ret+    fromValue' _ = throw ErrTypeMismatch++instance ToValue () where+    toValue () = ValueVoid+    fromValue ValueVoid = Just ()+    fromValue _ = Nothing+instance ToValue Int where+    toValue = ValueInt+    fromValue (ValueInt x) = Just x+    fromValue _ = Nothing+instance ToValue Double where+    toValue = ValueDouble+    fromValue (ValueDouble x) = Just x+    fromValue _ = Nothing+instance ToValue String where+    toValue = ValueString+    fromValue (ValueString x) = Just x+    fromValue _ = Nothing+instance ToValue Bool where+    toValue = ValueBool+    fromValue (ValueBool x) = Just x+    fromValue _ = Nothing+instance ToValue (M22 Double) where+    toValue = ValueMatrix+    fromValue (ValueMatrix x) = Just x+    fromValue _ = Nothing+instance ToValue CharSet where+    toValue = ValueCharSet+    fromValue (ValueCharSet x) = Just x+    fromValue _ = Nothing+instance ToValue FT_Face where+    toValue = ValueFTFace+    fromValue (ValueFTFace x) = Just x+    fromValue _ = Nothing+instance ToValue LangSet where+    toValue = ValueLangSet+    fromValue (ValueLangSet x) = Just x+    fromValue _ = Nothing+instance ToValue Range where+    toValue = ValueRange+    fromValue (ValueRange x) = Just x+    fromValue _ = Nothing++------+--- Low-level+------++type Value_ = Ptr Int++foreign import ccall "size_value" value'Size :: Int+pokeUnion ptr x = castPtr (ptr `advancePtr` 1) `poke` x++withValue :: Value -> (Value_ -> IO a) -> IO a+withValue ValueVoid cb = allocaBytes value'Size $ \val' -> do+    poke val' 0+    cb val'+withValue (ValueInt x) cb = allocaBytes value'Size $ \val' -> do+    poke val' 1+    pokeElemOff val' 1 x+    cb val'+withValue (ValueDouble x) cb = allocaBytes value'Size $ \val' -> do+    poke val' 2+    pokeUnion val' x+    cb val'+withValue (ValueString str) cb =+    withCString str $ \str' -> allocaBytes value'Size $ \val' -> do+        poke val' 3+        pokeUnion val' str'+        cb val'+withValue (ValueBool b) cb = allocaBytes value'Size $ \val' -> do+    poke val' 4+    pokeUnion val' b+    cb val'+withValue (ValueMatrix mat) cb =+    withMatrix mat $ \mat' -> allocaBytes value'Size $ \val' -> do+        poke val' 5+        pokeUnion val' mat'+        cb val'+withValue (ValueCharSet charsets) cb =+    withCharSet charsets $ \charsets' -> allocaBytes value'Size $ \val' -> do+        poke val' 6+        pokeUnion val' charsets'+        cb val'+withValue (ValueFTFace x) cb = allocaBytes value'Size $ \val' -> do+    poke val' 7+    pokeUnion val' x+    cb val'+withValue (ValueLangSet langset) cb =+    withLangSet langset $ \langset' -> allocaBytes value'Size $ \val' -> do+        poke val' 8+        pokeUnion val' langset'+        cb val'+withValue (ValueRange range) cb =+    withRange range $ \range' -> allocaBytes value'Size $ \val' -> do+        poke val' 9+        pokeUnion val' range'+        cb val'++foreign import ccall "size_matrix" mat22Size :: Int+withMatrix (V2 (V2 xx yx) (V2 xy yy)) cb = allocaBytes mat22Size $ \mat' -> do+    pokeElemOff mat' 0 xx+    pokeElemOff mat' 1 xy+    pokeElemOff mat' 2 yx+    pokeElemOff mat' 3 yy+    cb mat'++thawValue :: Value_ -> IO (Maybe Value)+thawValue ptr = do+    kind <- peek ptr+    let val' = castPtr (ptr `advancePtr` 1)+    case kind of+        0 -> return $ Just ValueVoid+        1 -> Just <$> ValueInt <$> peek val'+        2 -> Just <$> ValueDouble <$> peek val'+        3 -> do+            val <- throwNull <$> peek val'+            Just <$> ValueString <$> peekCString val+        4 -> Just <$> ValueBool <$> peek val'+        5 -> do+            mat' <- throwNull <$> peek val'+            xx <- peekElemOff mat' 0+            xy <- peekElemOff mat' 1+            yx <- peekElemOff mat' 2+            yy <- peekElemOff mat' 3+            return $ Just $ ValueMatrix $ V2 (V2 xx xy) (V2 yx yy)+        6 -> do+            val <- throwNull <$> peek val'+            Just <$> ValueCharSet <$> thawCharSet val+        7 -> Just <$> ValueFTFace <$> throwNull <$> peek val'+        8 -> do+            val <- throwNull <$> peek val'+            Just <$> ValueLangSet <$> thawLangSet val+        9 -> do+            val <- throwNull <$> peek val'+            Just <$> ValueRange <$> thawRange val+        _ -> return Nothing
+ Graphics/Text/Font/Choose/Weight.hs view
@@ -0,0 +1,20 @@+module Graphics.Text.Font.Choose.Weight where++-- | Returns an double value to use with "weight", from an double in the+-- 1..1000 range, resembling the numbers from OpenType specification's OS2+-- usWeight numbers, which are also similar to CSS font-weight numbers.+-- If input is negative, zero, or greater than 1000, returns -1.+-- This function linearly interpolates between various FC_WEIGHT_* constants.+-- As such, the returned value does not necessarily match any of the predefined+-- constants.+foreign import ccall "FcWeightFromOpenTypeDouble" weightFromOpenTypeDouble ::+    Double -> Double+-- | `weightToOpenTypeDouble` is the inverse of `weightFromOpenType`.+-- If the input is less than FC_WEIGHT_THIN or greater than FC_WEIGHT_EXTRABLACK,+-- returns -1. Otherwise returns a number in the range 1 to 1000.+foreign import ccall "FcWeightToOpenTypeDouble" weightToOpenTypeDouble ::+    Double -> Double+-- | Variant of `weightFromOpenTypeDouble` taking ints.+foreign import ccall "FcWeightFromOpenType" weightFromOpenType :: Int -> Int+-- | Variant of `weightToOpenTypeDouble` taking ints.+foreign import ccall "FcWeightToOpenType" weightToOpenType :: Int -> Int
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2022 Adrian Cochrane++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ Main.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE PackageImports #-}+module Main where++import "fontconfig-pure" Graphics.Text.Font.Choose as Font++import System.Environment (getArgs)+import Control.Monad (forM)++main :: IO ()+main = do+    args <- getArgs+    let (all, name, objects) = case args of {+        [] -> (False, "serif", []);+        "!":name:objects -> (True, name, objects);+        name:objects -> (False, name, objects)}+    let query = nameParse name+    print query+    let query' = defaultSubstitute $ configSubstitute' query MatchPattern+    print query'++    case fontSort' query' all of+        Just (res, charset) -> do+            print charset+            forM res $ \res' -> print $ fontRenderPrepare' query' res'+            return ()+        Nothing -> putStrLn "No results!"
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ cbits/pattern.c view
@@ -0,0 +1,41 @@+#include <fontconfig/fontconfig.h>+#include <stddef.h>++int my_FcCHARSET_MAP_SIZE() {+    return FC_CHARSET_MAP_SIZE;+}++FcBool my_FcPatternAdd(FcPattern *p, const char *object,+        FcBool binding, FcBool append, FcValue *value) {+    if (binding) {+        return FcPatternAdd(p, object, *value, append);+    } else {+        return FcPatternAddWeak(p, object, *value, append);+    }+}++int size_value() {+    return sizeof(FcValue);+}+int size_matrix() {+    return sizeof(FcMatrix);+}+int size_PatternIter() {+    return sizeof(FcPatternIter);+}++int size_ConfigFileInfoIter() {+    return sizeof(FcConfigFileInfoIter);+}++int get_fontSet_nfont(FcFontSet *fonts) {+    return fonts->nfont;+}++FcPattern *get_fontSet_font(FcFontSet *fonts, int i) {+    if (i < 0) return NULL;+    if (i >= fonts->nfont) return NULL;+    if (i >= fonts->sfont) return NULL;+    if (fonts->fonts == NULL) return NULL;+    return fonts->fonts[i];+}
+ fontconfig-pure.cabal view
@@ -0,0 +1,109 @@+-- Initial fontconfig-pure.cabal generated by cabal init.  For further+-- documentation, see http://haskell.org/cabal/users-guide/++-- The name of the package.+name:                fontconfig-pure++-- The package version.  See the Haskell package versioning policy (PVP)+-- for standards guiding when and how versions should be incremented.+-- https://wiki.haskell.org/Package_versioning_policy+-- PVP summary:      +-+------- breaking API changes+--                   | | +----- non-breaking API additions+--                   | | | +--- code changes with no API change+version:             0.1.0.0++-- A short (one-line) description of the package.+synopsis:            Pure-functional language bindings to FontConfig++-- A longer description of the package.+-- description:++-- URL for the project homepage or repository.+homepage:            https://www.freedesktop.org/wiki/Software/fontconfig/++-- The license under which the package is released.+license:             MIT++-- The file containing the license text.+license-file:        LICENSE++-- The package author(s).+author:              Adrian Cochrane++-- An email address to which users can send suggestions, bug reports, and+-- patches.+maintainer:          adrian@openwork.nz++-- A copyright notice.+-- copyright:++category:            Text++build-type:          Simple++-- Extra files to be distributed with the package, such as examples or a+-- README.+extra-source-files:  CHANGELOG.md++-- Constraint on the version of Cabal needed to build this package.+cabal-version:       >=1.10+++library+  -- Modules exported by the library.+  exposed-modules:    Graphics.Text.Font.Choose, FreeType.FontConfig++  -- Modules included in this library but not exported.+  other-modules:      Graphics.Text.Font.Choose.Result, Graphics.Text.Font.Choose.Pattern,+                Graphics.Text.Font.Choose.ObjectSet, Graphics.Text.Font.Choose.CharSet,+                Graphics.Text.Font.Choose.Strings, Graphics.Text.Font.Choose.Range,+                Graphics.Text.Font.Choose.LangSet, Graphics.Text.Font.Choose.Value,+                Graphics.Text.Font.Choose.FontSet, Graphics.Text.Font.Choose.FontSet.API,+                Graphics.Text.Font.Choose.Config, Graphics.Text.Font.Choose.Init,+                Graphics.Text.Font.Choose.Weight++  c-sources:    cbits/pattern.c++  -- LANGUAGE extensions used by modules in this package.+  -- other-extensions:++  -- Other library packages from which modules are imported.+  build-depends:       base >=4.12 && <4.13, containers >= 0.1 && <1,+                        linear >= 1.0.1 && <2, freetype2 >= 0.2 && < 0.3,+                        hashable >= 1.3 && <2,+                        css-syntax, text, stylist-traits >= 0.1.1 && < 1, scientific++  pkgconfig-depends:    fontconfig++  -- Directories containing source files.+  -- hs-source-dirs:++  -- Base language which the package is written in.+  default-language:    Haskell2010+++executable fontconfig-pure+  -- .hs or .lhs file containing the Main module.+  main-is:             Main.hs++  -- Modules included in this executable, other than Main.+  -- other-modules:++  -- LANGUAGE extensions used by modules in this package.+  -- other-extensions:++  -- Other library packages from which modules are imported.+  build-depends:       base >=4.12 && <4.13, fontconfig-pure++  -- Directories containing source files.+  -- hs-source-dirs:++  -- Base language which the package is written in.+  default-language:    Haskell2010++test-suite test-fontconfig+  hs-source-dirs: test+  default-language: Haskell2010+  type: exitcode-stdio-1.0+  main-is: Test.hs+  build-depends: base >= 4.12 && <4.13, fontconfig-pure, hspec, QuickCheck
+ test/Test.hs view
@@ -0,0 +1,32 @@+module Main where++import Test.Hspec+import Graphics.Text.Font.Choose++main :: IO ()+main = hspec spec++test query expect = nameParse query `shouldBe` expect++spec :: Spec+spec = do+    describe "Canary" $ do+        it "Test framework works" $ do+            True `shouldBe` True+    describe "Name Parse" $ do+        it "parses as expected" $ do+            "sans\\-serif" `test` [("family", [(Weak, ValueString "sans-serif")])]+            "Foo-10" `test` [("family", [(Weak, ValueString "Foo")]),+                            ("size", [(Weak, ValueDouble 10.0)])]+            "Foo,Bar-10" `test` [+                ("family", [(Weak, ValueString "Foo"), (Weak, ValueString "Bar")]),+                ("size", [(Weak, ValueDouble 10.0)])]+            "Foo:weight=medium" `test` [("family", [(Weak, ValueString "Foo")]),+                                        ("weight", [(Weak, ValueDouble 100.0)])]+            "Foo:weight_medium" `test` [("family", [(Weak, ValueString "Foo")]),+                                        ("weight", [(Weak, ValueDouble 100.0)])]+            ":medium" `test` [("weight", [(Weak, ValueInt 100)])]+            ":normal" `test` [("width", [(Weak, ValueInt 100)])]+            ":weight=[medium bold]" `test` [+                    ("weight", [(Weak, ValueRange $ Range 100.0 200.0)])]+    -- FIXME test more...