packages feed

fontconfig-pure 0.4.0.0 → 0.5.1.0

raw patch · 49 files changed

Files

CHANGELOG.md view
@@ -1,10 +1,22 @@ # Revision history for fontconfig-pure -## 0.3.0.0 -- 2023-10-01+## 0.5.1.0 -- 2025-02-04 -* Addressing segfaults & mainloops.-* Switched underlying CharSet collection to IntSet for efficiency.+* Expose a pure accessor for the current config (for API ergonomics, meant to earlier) -## 0.1.0.0 -- YYYY-mm-dd+## 0.5.0.3 -- 2025-01-17++* Better descriptions for Hackage+* More explicit version bounds on the dependencies++## 0.5.0.1 -- 2025-01-17++* Added a README file+* Improved metadata, notably instructions on how to contribute.+* Include missing C headerfiles.++Apologies for having overlooked these previously!++## 0.5 -- YYYY-mm-dd  * First version. Released on an unsuspecting world.
− FreeType/FontConfig.hs 
@@ -1,391 +0,0 @@--- NOTE: Not tested-module FreeType.FontConfig (ftCharIndex, ftCharSet, ftCharSetAndSpacing,-    ftQuery, ftQueryAll, ftQueryFace,-    FTFC_Instance(..), FTFC_Metrics(..), FTFC_Subpixel(..), instantiatePattern,-    FTFC_Glyph(..), glyphForIndex, bmpAndMetricsForIndex) 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--    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 $ fromEnum $-        fromMaybe req_px_size $ getValue' "pixelsize" pattern-    let scalable = fromMaybe True $ getValue' "scalable" pattern-    let outline = fromMaybe True $ getValue' "outline" pattern-    (pixel_fixup, fixup_estimated) <- case getValue "pixelsizefixupfactor" pattern of-        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,-    glyphMetrics :: FT_Glyph_Metrics-}---- | Looks up a given glyph in a `FTFC_Instance` & its underlying `FT_Face`--- Taking into account additional properties from FontConfig.--- Runs a provided callback to render the glyph into a reusable datastructure.--- The `FT_Bitmap` given to this callback must not be used outside it.--- Throws exceptions.-glyphForIndex :: FTFC_Instance -> Word32 -> FTFC_Subpixel -> -    (FT_Bitmap -> IO a) -> IO (FTFC_Glyph a)-glyphForIndex font index subpixel cb = do-    ft_Load_Glyph (fontFace font) index (toEnum $ fontLoadFlags font)-    face' <- peek $ fontFace font-    size' <- peek $ frSize face'-    -- Formula from old FreeType function `FT_GlyphSlotEmbolden`.-    -- Approximate as fallback for fonts not using fontsets or variables axis.-    let strength = fromIntegral (frUnits_per_EM face')*smY_scale (srMetrics size')`div`24-    glyph' <- peek $ frGlyph face'--    glyph1' <- case gsrFormat glyph' of-        FT_GLYPH_FORMAT_OUTLINE | fontEmbolden font -> do-            outline <- withPtr (gsrOutline glyph') $ flip ft_Outline_Embolden strength-            return glyph' { gsrOutline = outline }-        _ -> return glyph'--    let render_flags = case subpixel of {--- FT_GLYPH_FORMAT_SVG is not exposed by our language bindings,--- Should be largely irrelevant now... Certain FreeType versions required this flag.---        _ | FT_GLYPH_FORMAT_SVG <- gsrFormat glyph1' -> ft_RENDER_MODE_NORMAL;-        _ | not $ fontAntialias font -> fontRenderFlags font;-        SubpixelNone -> fontRenderFlags font;-        SubpixelHorizontalRGB -> ft_RENDER_MODE_LCD;-        SubpixelHorizontalBGR -> ft_RENDER_MODE_LCD;-        SubpixelVerticalRGB -> ft_RENDER_MODE_LCD_V;-        SubpixelVerticalBGR -> ft_RENDER_MODE_LCD_V;-        SubpixelDefault -> fontRenderFlagsSubpixel font}-    let bgr = case subpixel of {-        _ | not $ fontAntialias font -> False;-        SubpixelNone -> False;-        SubpixelHorizontalRGB -> False;-        SubpixelHorizontalBGR -> True;-        SubpixelVerticalRGB -> False;-        SubpixelVerticalBGR -> True;-        SubpixelDefault -> fontBGR font}--    can_set_lcd_filter <- isSuccess $ ft_Library_SetLcdFilter (gsrLibrary glyph1') 0-    -- FIXME: Do we need a mutex?-    let set_lcd_filter = ft_Library_SetLcdFilter (gsrLibrary glyph1') $ fontLCDFilter font-    case render_flags of {-        FT_RENDER_MODE_LCD | can_set_lcd_filter -> set_lcd_filter;-        FT_RENDER_MODE_LCD_V | can_set_lcd_filter -> set_lcd_filter;-        _ -> return ()}--    glyph2' <- case gsrFormat glyph1' of {-        FT_GLYPH_FORMAT_BITMAP -> return glyph1';-        _ -> withPtr glyph1' $ flip ft_Render_Glyph $ toEnum render_flags}-    -- If set_lcd_filter requires mutex, release it here.-    case gsrFormat glyph2' of {-        FT_GLYPH_FORMAT_BITMAP -> return ();-        _ -> throw $ FtError "glyphForIndex" 2-    }--    img <- cb $ gsrBitmap glyph2'-    return Glyph {-        glyphFontName = fontName font, glyphImage = img,-        glyphAdvance = (fromIntegral (vX $ gsrAdvance glyph2') / 64 *-            if fontPixelFixupEstimated font then fontPixelSizeFixup font else 1,-            fromIntegral (vY $ gsrAdvance glyph2') / 64 *-            if fontPixelFixupEstimated font then fontPixelSizeFixup font else 1),-        glyphSubpixel = subpixel,-        glyphMetrics = gsrMetrics glyph2'-    }--bmpAndMetricsForIndex ::-    FTFC_Instance -> FTFC_Subpixel -> Word32 -> IO (FT_Bitmap, FT_Glyph_Metrics)-bmpAndMetricsForIndex inst subpixel index = do-    glyph <- glyphForIndex inst index subpixel pure-    return (glyphImage glyph, glyphMetrics glyph)--withPtr :: Storable a => a -> (Ptr a -> IO b) -> IO a-withPtr a cb = alloca $ \a' -> do-    poke a' a-    cb a'-    peek a'--isSuccess :: IO a -> IO Bool-isSuccess cb = do-    cb-    return True-  `catch` \(FtError _ _) -> return False--m22toFt :: M22 Double -> FT_Matrix-m22toFt (V2 (V2 xx xy) (V2 yx yy)) = FT_Matrix {-    mXx = c xx * 0x10000, mXy = c xy * 0x10000,-    mYx = c yx * 0x10000, mYy = c yy * 0x10000-  } where c = toEnum . fromEnum---- Taken from FreeType language bindings,--- but converted to constants rather than pattern synonyms.-ft_LOAD_DEFAULT, ft_LOAD_NO_SCALE, ft_LOAD_NO_HINTING, ft_LOAD_RENDER,-    ft_LOAD_NO_BITMAP, ft_LOAD_VERTICAL_LAYOUT, ft_LOAD_FORCE_AUTOHINT,-    ft_LOAD_CROP_BITMAP, ft_LOAD_PEDANTIC, ft_LOAD_IGNORE_GLOBAL_ADVANCE_WIDTH,-    ft_LOAD_NO_RECURSE, ft_LOAD_IGNORE_TRANSFORM, ft_LOAD_MONOCHROME,-    ft_LOAD_LINEAR_DESIGN, ft_LOAD_NO_AUTOHINT, ft_LOAD_COLOR,-    ft_LOAD_COMPUTE_METRICS, ft_LOAD_BITMAP_METRICS_ONLY :: Int-ft_LOAD_DEFAULT                     = 0-ft_LOAD_NO_SCALE                    = 1-ft_LOAD_NO_HINTING                  = 2-ft_LOAD_RENDER                      = 4-ft_LOAD_NO_BITMAP                   = 8-ft_LOAD_VERTICAL_LAYOUT             = 16-ft_LOAD_FORCE_AUTOHINT              = 32-ft_LOAD_CROP_BITMAP                 = 64-ft_LOAD_PEDANTIC                    = 128-ft_LOAD_IGNORE_GLOBAL_ADVANCE_WIDTH = 512-ft_LOAD_NO_RECURSE                  = 1024-ft_LOAD_IGNORE_TRANSFORM            = 2048-ft_LOAD_MONOCHROME                  = 4096-ft_LOAD_LINEAR_DESIGN               = 8192-ft_LOAD_NO_AUTOHINT                 = 32768-ft_LOAD_COLOR                       = 1048576-ft_LOAD_COMPUTE_METRICS             = 2097152-ft_LOAD_BITMAP_METRICS_ONLY         = 4194304--ft_LOAD_TARGET_NORMAL, ft_LOAD_TARGET_LIGHT, ft_LOAD_TARGET_MONO,-    ft_LOAD_TARGET_LCD, ft_LOAD_TARGET_LCD_V :: Int-ft_LOAD_TARGET_NORMAL = 0-ft_LOAD_TARGET_LIGHT  = 65536-ft_LOAD_TARGET_MONO   = 131072-ft_LOAD_TARGET_LCD    = 196608-ft_LOAD_TARGET_LCD_V  = 262144--ft_RENDER_MODE_NORMAL, ft_RENDER_MODE_LIGHT, ft_RENDER_MODE_MONO,-    ft_RENDER_MODE_LCD, ft_RENDER_MODE_LCD_V :: Int-ft_RENDER_MODE_NORMAL = 0-ft_RENDER_MODE_LIGHT  = 1-ft_RENDER_MODE_MONO   = 2-ft_RENDER_MODE_LCD    = 3-ft_RENDER_MODE_LCD_V  = 4
− Graphics/Text/Font/Choose.hs 
@@ -1,60 +0,0 @@-module Graphics.Text.Font.Choose(CharSet, chr, ord, 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 Data.Char (chr, ord) -- For use with CharSet--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 
@@ -1,98 +0,0 @@-module Graphics.Text.Font.Choose.CharSet where--import Data.IntSet (IntSet, union)-import qualified Data.IntSet as IntSet-import Graphics.Text.Font.Choose.Result (throwNull, throwFalse)-import System.IO.Unsafe (unsafeInterleaveIO)--import Data.Word (Word32)-import Foreign.Ptr-import Foreign.ForeignPtr (newForeignPtr, withForeignPtr)-import Control.Exception (bracket)-import Foreign.Storable (peek)-import Control.Monad (forM)-import Foreign.Marshal.Alloc (alloca)-import Foreign.Marshal.Array (allocaArray)-import GHC.Base (unsafeChr)-import Data.Char (ord, isHexDigit)-import Numeric (readHex)---- | An FcCharSet is a set of Unicode chars.-type CharSet = IntSet--parseChar :: String -> Int-parseChar str | ((x, _):_) <- readHex str = toEnum x-replaceWild :: Char -> String -> String-replaceWild ch ('?':rest) = ch:replaceWild ch rest-replaceWild ch (c:cs) = c:replaceWild ch cs-replaceWild _ "" = ""-parseWild :: Char -> String -> Int-parseWild ch str = parseChar $ replaceWild ch str--- | Utility for parsing "unicode-range" @font-face property.-parseCharSet :: String -> Maybe CharSet-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 $ union set $ IntSet.fromList [parseChar start..parseChar end]-    | (codepoint@(_:_), rest) <- span isHexDigit cs, Just set <- parseCharSet' rest =-        Just $ flip IntSet.insert set $ parseChar codepoint-    | (codepoint@(_:_), rest) <- span (\c -> isHexDigit c || c == '?') cs,-        Just set <- parseCharSet' rest =-            Just $ IntSet.union set $ IntSet.fromList [-                parseWild '0' codepoint..parseWild 'f' codepoint]-parseCharSet _ = Nothing-parseCharSet' :: String -> Maybe CharSet-parseCharSet' (',':rest) = parseCharSet rest-parseCharSet' "" = Just IntSet.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 (IntSet.elems chars) $ \ch' ->-        throwFalse <$> (fcCharSetAddChar chars' $ fromIntegral ch')-    cb chars'-foreign import ccall "FcCharSetAddChar" fcCharSetAddChar :: CharSet_ -> Word32 -> IO Bool--thawCharSet :: CharSet_ -> IO CharSet-thawCharSet chars'-    | chars' == nullPtr = return IntSet.empty-    | otherwise = do-        iter' <- throwNull <$> fcCharSetIterCreate chars'-        iter <- newForeignPtr (fcCharSetIterDestroy) iter'-        x <- withForeignPtr iter fcCharSetIterStart-        let go x' | fcCharSetIterDone x' = return []-                | otherwise = unsafeInterleaveIO $ do-                    y <- withForeignPtr iter fcCharSetIterNext-                    xs <- go y-                    return (x':xs)-        ret <- go x-        return $ IntSet.fromList $ map (fromIntegral) ret-data CharSetIter'-type CharSetIter_ = Ptr CharSetIter'-foreign import ccall "my_FcCharSetIterCreate" fcCharSetIterCreate ::-    CharSet_ -> IO CharSetIter_-foreign import ccall "&my_FcCharSetIterDestroy" fcCharSetIterDestroy ::-    FunPtr (CharSetIter_ -> IO ())-foreign import ccall "my_FcCharSetIterStart" fcCharSetIterStart ::-    CharSetIter_ -> IO Word32-foreign import ccall "my_FcCharSetIterNext" fcCharSetIterNext ::-    CharSetIter_ -> IO Word32-foreign import ccall "my_FcCharSetIterDone" fcCharSetIterDone :: Word32 -> Bool--thawCharSet_ :: IO CharSet_ -> IO CharSet-thawCharSet_ cb = bracket (throwNull <$> cb) fcCharSetDestroy thawCharSet-thawCharSet' :: Ptr CharSet_ -> IO CharSet-thawCharSet' = thawCharSet_ . peek
− Graphics/Text/Font/Choose/Config.hs 
@@ -1,406 +0,0 @@-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 Data.Set (empty) -- For testing segfault source.--import Control.Exception (bracket)-import Graphics.Text.Font.Choose.Result (Word8, 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 Word8 -> 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' -> alloca $ \csp' -> alloca $ \res' -> do-            ret <- fcFontSort config' pattern' trim csp' res'-            throwPtr res' $ do-                x <- thawFontSet_ $ pure ret-                y <- thawCharSet' 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' ->-    alloca $ \csp' -> alloca $ \res' -> do-        ret <- fcFontSort nullPtr pattern' trim csp' res'-        throwPtr res' $ do-            x <- thawFontSet_ $ pure ret-            y <- thawCharSet' csp'-            return (x, y)-foreign import ccall "FcFontSort" fcFontSort ::-    Config_ -> Pattern_ -> Bool -> Ptr CharSet_ -> Ptr Word8 -> 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 
@@ -1,147 +0,0 @@-{-# 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)-import System.IO.Unsafe (unsafeInterleaveIO)---- 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-    n <- get_fontSet_nfont fonts'-    if n == 0 then return []-    else-        forM [0..pred n] (\i -> thawPattern' =<< get_fontSet_font fonts' i)-  where-    thawPattern' pat = do-        fcPatternReference pat-        unsafeInterleaveIO $ thawPattern pat-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 
@@ -1,83 +0,0 @@--- 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 (Word8, 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 Word8 -> 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 -> Maybe (FontSet, CharSet)-fontSetSort config fontss pattern trim = unsafePerformIO $-    withForeignPtr config $ \config' -> withFontSets fontss $ \fontss' n ->-        withPattern pattern $ \pattern' -> alloca $ \csp' -> alloca $ \res' -> do-            ret' <- fcFontSetSort config' fontss' n pattern' trim csp' res'-            throwPtr res' $ do-                x <- thawFontSet_ $ pure ret'-                y <- thawCharSet' csp'-                return (x, y)--- | Variant of `fontSetSort` operating upon registered default `Config`.-fontSetSort' :: [FontSet] -> Pattern -> Bool -> Maybe (FontSet, CharSet)-fontSetSort' fontss pattern trim = unsafePerformIO $-    withFontSets fontss $ \fontss' n -> withPattern pattern $ \pattern' ->-        alloca $ \csp' -> alloca $ \res' -> do-            ret' <- fcFontSetSort nullPtr fontss' n pattern' trim csp' res'-            throwPtr res' $ do-                x <- thawFontSet_ $ pure ret'-                y <- thawCharSet' csp'-                return (x, y)-foreign import ccall "FcFontSetSort" fcFontSetSort :: Config_ -> Ptr FontSet_-    -> Int -> Pattern_ -> Bool -> Ptr CharSet_ -> Ptr Word8 -> IO FontSet_
− Graphics/Text/Font/Choose/Init.hs 
@@ -1,44 +0,0 @@-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 
@@ -1,107 +0,0 @@-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 
@@ -1,32 +0,0 @@-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 
@@ -1,354 +0,0 @@-{-# 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,-    fcPatternReference,--    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, FunPtr)-import Foreign.ForeignPtr (ForeignPtr,-        newForeignPtr, withForeignPtr, mallocForeignPtrBytes)-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, unsafeInterleaveIO)--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' = do-    iter <- mallocForeignPtrBytes patIter'Size-    pat <- gcPattern pat'-    with2ForeignPtrs pat iter fcPatternIterStart-    ret <- go pat iter-    return $ normalizePattern ret-  where-    go :: ForeignPtr Pattern' -> ForeignPtr PatternIter' -> IO Pattern-    go pat iter = unsafeInterleaveIO $ do-        ok <- with2ForeignPtrs pat iter fcPatternIterIsValid-        if ok then do-            x <- with2ForeignPtrs pat iter thawPattern'-            ok' <- with2ForeignPtrs pat iter fcPatternIterNext-            xs <- if ok' then go pat iter else return []-            return (x : xs)-        else return []-    with2ForeignPtrs a b cb = withForeignPtr a $ \a' -> withForeignPtr b $ cb a'-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 ()-foreign import ccall "&FcPatternDestroy" fcPatternDestroy' ::-    FunPtr (Pattern_ -> IO ())--gcPattern :: Pattern_ -> IO (ForeignPtr Pattern')-gcPattern pat' = do-    fcPatternReference pat'-    newForeignPtr fcPatternDestroy' pat'------------ 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 
@@ -1,39 +0,0 @@-{-# 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 
@@ -1,43 +0,0 @@-module Graphics.Text.Font.Choose.Result (Result(..), Word8, resultFromPointer,-    Error(..), throwResult, throwInt, throwPtr, throwFalse, throwNull) where--import Foreign.Storable (peek)-import Foreign.Ptr (Ptr, nullPtr)-import Control.Exception (throwIO, throw, Exception)-import Data.Word (Word8)--data Result = Match | NoMatch | TypeMismatch | ResultNoId | OutOfMemory | Other-    deriving (Eq, Show, Read, Enum, Bounded)--resultFromPointer :: Ptr Word8 -> IO Result-resultFromPointer res = toEnum8 <$> peek res--toEnum8 :: Enum a => Word8 -> a-toEnum8 = toEnum . fromEnum--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 x-    | x >= 0 && x <= 4 = throwResult $ toEnum x-    | otherwise = throwResult $ Other-throwPtr :: Ptr Word8 -> 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 
@@ -1,75 +0,0 @@-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 
@@ -1,178 +0,0 @@-{-# 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 (Word8, 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 $ castPtr ptr :: IO Word8-    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 
@@ -1,20 +0,0 @@-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
@@ -1,4 +1,4 @@-Copyright (c) 2022 Adrian Cochrane+Copyright (c) 2024 Adrian Cochrane  Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the
− Main.hs 
@@ -1,26 +0,0 @@-{-# 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!"
+ README.md view
@@ -0,0 +1,19 @@+# FontConfig-Pure+[Repository](https://git.argonaut-constellation.org/~alcinnz/fontconfig-pure) | [Issue Tracker](https://todo.argonaut-constellation.org/fontconfig-pure) | [Hackage](https://hackage.haskell.org/package/fontconfig-pure)++Pure-functional language bindings to [FontConfig](https://www.freedesktop.org/wiki/Software/fontconfig/), which queries & configures your freedesktop's system font database on Linux/BSD/etc.++That is given a font family & style it'll tell which user-installed font to use!++Adds compatibility with [Haskell Stylist](https://hackage.haskell.org/package/stylist), so you can use CSS syntax.++## Contributing+Please send patches to our [issue tracker](https://todo.argonaut-constellation.org/~alcinnz/fontconfig-pure) by either:++* Attaching the output of `git format-patch`.+* [git send-email](https://git-send-email.io/) to ~alcinnz/fontconfig-pure@todo.argonaut-constellation.org .+* Linking to your fork elsewhere.++Whichever you find most convenient.++If you'd prefer to not make your email address public please contact alcinnz@argonaut-constellation.org !
− Setup.hs 
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
+ app/Main.hs view
@@ -0,0 +1,6 @@+module Main where+++main :: IO ()+main = do+  putStrLn "Hello, Haskell!"
+ cbits/SOURCES view
@@ -0,0 +1,3 @@+`cmp.h` & `cmp.c` are from https://github.com/camgunz/cmp under the MIT license.++These have been vendored since its a stable library which might not be available in common package repos.
− cbits/charsetiter.c 
@@ -1,31 +0,0 @@-#include <fontconfig/fontconfig.h>-#include <stdlib.h>--struct my_FcCharSetIter {-    FcCharSet *charset;-    FcChar32 map[FC_CHARSET_MAP_SIZE];-    FcChar32 next;-};--struct my_FcCharSetIter *my_FcCharSetIterCreate(FcCharSet *a) {-    struct my_FcCharSetIter *self = malloc(sizeof(struct my_FcCharSetIter));-    self->charset = FcCharSetCopy(a);-    return self;-}--void my_FcCharSetIterDestroy(struct my_FcCharSetIter *self) {-    FcCharSetDestroy(self->charset);-    free(self);-}--FcChar32 my_FcCharSetIterStart(struct my_FcCharSetIter *self) {-    return FcCharSetFirstPage(self->charset, self->map, &self->next);-}--FcChar32 my_FcCharSetIterNext(struct my_FcCharSetIter *self) {-    return FcCharSetNextPage(self->charset, self->map, &self->next);-}--FcBool my_FcCharSetIterDone(FcChar32 chr) {-    return chr == FC_CHARSET_DONE;-}
+ cbits/cmp.c view
@@ -0,0 +1,3561 @@+/*+The MIT License (MIT)++Copyright (c) 2020 Charles Gunyon++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.+*/++#include "cmp.h"++static const uint32_t cmp_version_ = 20;+static const uint32_t cmp_mp_version_ = 5;++enum {+  POSITIVE_FIXNUM_MARKER = 0x00,+  FIXMAP_MARKER          = 0x80,+  FIXARRAY_MARKER        = 0x90,+  FIXSTR_MARKER          = 0xA0,+  NIL_MARKER             = 0xC0,+  FALSE_MARKER           = 0xC2,+  TRUE_MARKER            = 0xC3,+  BIN8_MARKER            = 0xC4,+  BIN16_MARKER           = 0xC5,+  BIN32_MARKER           = 0xC6,+  EXT8_MARKER            = 0xC7,+  EXT16_MARKER           = 0xC8,+  EXT32_MARKER           = 0xC9,+  FLOAT_MARKER           = 0xCA,+  DOUBLE_MARKER          = 0xCB,+  U8_MARKER              = 0xCC,+  U16_MARKER             = 0xCD,+  U32_MARKER             = 0xCE,+  U64_MARKER             = 0xCF,+  S8_MARKER              = 0xD0,+  S16_MARKER             = 0xD1,+  S32_MARKER             = 0xD2,+  S64_MARKER             = 0xD3,+  FIXEXT1_MARKER         = 0xD4,+  FIXEXT2_MARKER         = 0xD5,+  FIXEXT4_MARKER         = 0xD6,+  FIXEXT8_MARKER         = 0xD7,+  FIXEXT16_MARKER        = 0xD8,+  STR8_MARKER            = 0xD9,+  STR16_MARKER           = 0xDA,+  STR32_MARKER           = 0xDB,+  ARRAY16_MARKER         = 0xDC,+  ARRAY32_MARKER         = 0xDD,+  MAP16_MARKER           = 0xDE,+  MAP32_MARKER           = 0xDF,+  NEGATIVE_FIXNUM_MARKER = 0xE0+};++enum {+  FIXARRAY_SIZE = 0xF,+  FIXMAP_SIZE   = 0xF,+  FIXSTR_SIZE   = 0x1F+};++enum {+  ERROR_NONE,+  STR_DATA_LENGTH_TOO_LONG_ERROR,+  BIN_DATA_LENGTH_TOO_LONG_ERROR,+  ARRAY_LENGTH_TOO_LONG_ERROR,+  MAP_LENGTH_TOO_LONG_ERROR,+  INPUT_VALUE_TOO_LARGE_ERROR,+  FIXED_VALUE_WRITING_ERROR,+  TYPE_MARKER_READING_ERROR,+  TYPE_MARKER_WRITING_ERROR,+  DATA_READING_ERROR,+  DATA_WRITING_ERROR,+  EXT_TYPE_READING_ERROR,+  EXT_TYPE_WRITING_ERROR,+  INVALID_TYPE_ERROR,+  LENGTH_READING_ERROR,+  LENGTH_WRITING_ERROR,+  SKIP_DEPTH_LIMIT_EXCEEDED_ERROR,+  INTERNAL_ERROR,+  DISABLED_FLOATING_POINT_ERROR,+  ERROR_MAX+};++static const char * const cmp_error_messages[ERROR_MAX + 1] = {+  "No Error",+  "Specified string data length is too long (> 0xFFFFFFFF)",+  "Specified binary data length is too long (> 0xFFFFFFFF)",+  "Specified array length is too long (> 0xFFFFFFFF)",+  "Specified map length is too long (> 0xFFFFFFFF)",+  "Input value is too large",+  "Error writing fixed value",+  "Error reading type marker",+  "Error writing type marker",+  "Error reading packed data",+  "Error writing packed data",+  "Error reading ext type",+  "Error writing ext type",+  "Invalid type",+  "Error reading size",+  "Error writing size",+  "Depth limit exceeded while skipping",+  "Internal error",+  "Floating point operations disabled",+  "Max Error"+};++#ifdef WORDS_BIGENDIAN+#define is_bigendian() (WORDS_BIGENDIAN)+#else+static const int32_t i_ = 1;+#define is_bigendian() ((*(const char *)&i_) == 0)+#endif++static uint16_t be16(uint16_t x) {+  char *b = (char *)&x;++  if (!is_bigendian()) {+    char swap = b[0];+    b[0] = b[1];+    b[1] = swap;+  }++  return x;+}++static int16_t sbe16(int16_t x) {+  return (int16_t)be16((uint16_t)x);+}++static uint32_t be32(uint32_t x) {+  char *b = (char *)&x;++  if (!is_bigendian()) {+    char swap = b[0];+    b[0] = b[3];+    b[3] = swap;++    swap = b[1];+    b[1] = b[2];+    b[2] = swap;+  }++  return x;+}++static int32_t sbe32(int32_t x) {+  return (int32_t)be32((uint32_t)x);+}++static uint64_t be64(uint64_t x) {+  char *b = (char *)&x;++  if (!is_bigendian()) {+    char swap;++    swap = b[0];+    b[0] = b[7];+    b[7] = swap;++    swap = b[1];+    b[1] = b[6];+    b[6] = swap;++    swap = b[2];+    b[2] = b[5];+    b[5] = swap;++    swap = b[3];+    b[3] = b[4];+    b[4] = swap;+  }++  return x;+}++static int64_t sbe64(int64_t x) {+  return (int64_t)be64((uint64_t)x);+}++#ifndef CMP_NO_FLOAT+static float decode_befloat(const char *b) {+  float f = 0.;+  char *fb = (char *)&f;++  if (!is_bigendian()) {+    fb[0] = b[3];+    fb[1] = b[2];+    fb[2] = b[1];+    fb[3] = b[0];+  }+  else {+    fb[0] = b[0];+    fb[1] = b[1];+    fb[2] = b[2];+    fb[3] = b[3];+  }++  return f;+}++static double decode_bedouble(const char *b) {+  double d = 0.;+  char *db = (char *)&d;++  if (!is_bigendian()) {+    db[0] = b[7];+    db[1] = b[6];+    db[2] = b[5];+    db[3] = b[4];+    db[4] = b[3];+    db[5] = b[2];+    db[6] = b[1];+    db[7] = b[0];+  }+  else {+    db[0] = b[0];+    db[1] = b[1];+    db[2] = b[2];+    db[3] = b[3];+    db[4] = b[4];+    db[5] = b[5];+    db[6] = b[6];+    db[7] = b[7];+  }++  return d;+}+#endif /* CMP_NO_FLOAT */++static bool read_byte(cmp_ctx_t *ctx, uint8_t *x) {+  return ctx->read(ctx, x, sizeof(uint8_t));+}++static bool write_byte(cmp_ctx_t *ctx, uint8_t x) {+  return (ctx->write(ctx, &x, sizeof(uint8_t)) == (sizeof(uint8_t)));+}++static bool skip_bytes(cmp_ctx_t *ctx, size_t count) {+  if (ctx->skip) {+    return ctx->skip(ctx, count);+  }+  else {+    uint8_t floor;+    size_t i;++    for (i = 0; i < count; i++) {+      if (!ctx->read(ctx, &floor, sizeof(uint8_t))) {+        return false;+      }+    }++    return true;+  }+}++static bool read_type_marker(cmp_ctx_t *ctx, uint8_t *marker) {+  if (read_byte(ctx, marker)) {+    return true;+  }++  ctx->error = TYPE_MARKER_READING_ERROR;+  return false;+}++static bool write_type_marker(cmp_ctx_t *ctx, uint8_t marker) {+  if (write_byte(ctx, marker))+    return true;++  ctx->error = TYPE_MARKER_WRITING_ERROR;+  return false;+}++static bool write_fixed_value(cmp_ctx_t *ctx, uint8_t value) {+  if (write_byte(ctx, value))+    return true;++  ctx->error = FIXED_VALUE_WRITING_ERROR;+  return false;+}++static bool type_marker_to_cmp_type(uint8_t type_marker, uint8_t *cmp_type) {+  if (type_marker <= 0x7F) {+    *cmp_type = CMP_TYPE_POSITIVE_FIXNUM;+    return true;+  }++  if (type_marker <= 0x8F) {+    *cmp_type = CMP_TYPE_FIXMAP;+    return true;+  }++  if (type_marker <= 0x9F) {+    *cmp_type = CMP_TYPE_FIXARRAY;+    return true;+  }++  if (type_marker <= 0xBF) {+    *cmp_type = CMP_TYPE_FIXSTR;+    return true;+  }++  if (type_marker >= 0xE0) {+    *cmp_type = CMP_TYPE_NEGATIVE_FIXNUM;+    return true;+  }++  switch (type_marker) {+    case NIL_MARKER:+      *cmp_type = CMP_TYPE_NIL;+      return true;+    case FALSE_MARKER:+      *cmp_type = CMP_TYPE_BOOLEAN;+      return true;+    case TRUE_MARKER:+      *cmp_type = CMP_TYPE_BOOLEAN;+      return true;+    case BIN8_MARKER:+      *cmp_type = CMP_TYPE_BIN8;+      return true;+    case BIN16_MARKER:+      *cmp_type = CMP_TYPE_BIN16;+      return true;+    case BIN32_MARKER:+      *cmp_type = CMP_TYPE_BIN32;+      return true;+    case EXT8_MARKER:+      *cmp_type = CMP_TYPE_EXT8;+      return true;+    case EXT16_MARKER:+      *cmp_type = CMP_TYPE_EXT16;+      return true;+    case EXT32_MARKER:+      *cmp_type = CMP_TYPE_EXT32;+      return true;+    case FLOAT_MARKER:+      *cmp_type = CMP_TYPE_FLOAT;+      return true;+    case DOUBLE_MARKER:+      *cmp_type = CMP_TYPE_DOUBLE;+      return true;+    case U8_MARKER:+      *cmp_type = CMP_TYPE_UINT8;+      return true;+    case U16_MARKER:+      *cmp_type = CMP_TYPE_UINT16;+      return true;+    case U32_MARKER:+      *cmp_type = CMP_TYPE_UINT32;+      return true;+    case U64_MARKER:+      *cmp_type = CMP_TYPE_UINT64;+      return true;+    case S8_MARKER:+      *cmp_type = CMP_TYPE_SINT8;+      return true;+    case S16_MARKER:+      *cmp_type = CMP_TYPE_SINT16;+      return true;+    case S32_MARKER:+      *cmp_type = CMP_TYPE_SINT32;+      return true;+    case S64_MARKER:+      *cmp_type = CMP_TYPE_SINT64;+      return true;+    case FIXEXT1_MARKER:+      *cmp_type = CMP_TYPE_FIXEXT1;+      return true;+    case FIXEXT2_MARKER:+      *cmp_type = CMP_TYPE_FIXEXT2;+      return true;+    case FIXEXT4_MARKER:+      *cmp_type = CMP_TYPE_FIXEXT4;+      return true;+    case FIXEXT8_MARKER:+      *cmp_type = CMP_TYPE_FIXEXT8;+      return true;+    case FIXEXT16_MARKER:+      *cmp_type = CMP_TYPE_FIXEXT16;+      return true;+    case STR8_MARKER:+      *cmp_type = CMP_TYPE_STR8;+      return true;+    case STR16_MARKER:+      *cmp_type = CMP_TYPE_STR16;+      return true;+    case STR32_MARKER:+      *cmp_type = CMP_TYPE_STR32;+      return true;+    case ARRAY16_MARKER:+      *cmp_type = CMP_TYPE_ARRAY16;+      return true;+    case ARRAY32_MARKER:+      *cmp_type = CMP_TYPE_ARRAY32;+      return true;+    case MAP16_MARKER:+      *cmp_type = CMP_TYPE_MAP16;+      return true;+    case MAP32_MARKER:+      *cmp_type = CMP_TYPE_MAP32;+      return true;+    default:+      return false;+  }+}++static bool read_type_size(cmp_ctx_t *ctx, uint8_t type_marker,+                                           uint8_t cmp_type,+                                           uint32_t *size) {+  uint8_t u8temp = 0;+  uint16_t u16temp = 0;+  uint32_t u32temp = 0;++  switch (cmp_type) {+    case CMP_TYPE_POSITIVE_FIXNUM:+      *size = 0;+      return true;+    case CMP_TYPE_FIXMAP:+      *size = (type_marker & FIXMAP_SIZE);+      return true;+    case CMP_TYPE_FIXARRAY:+      *size = (type_marker & FIXARRAY_SIZE);+      return true;+    case CMP_TYPE_FIXSTR:+      *size = (type_marker & FIXSTR_SIZE);+      return true;+    case CMP_TYPE_NIL:+      *size = 0;+      return true;+    case CMP_TYPE_BOOLEAN:+      *size = 0;+      return true;+    case CMP_TYPE_BIN8:+      if (!ctx->read(ctx, &u8temp, sizeof(uint8_t))) {+        ctx->error = LENGTH_READING_ERROR;+        return false;+      }+      *size = u8temp;+      return true;+    case CMP_TYPE_BIN16:+      if (!ctx->read(ctx, &u16temp, sizeof(uint16_t))) {+        ctx->error = LENGTH_READING_ERROR;+        return false;+      }+      *size = be16(u16temp);+      return true;+    case CMP_TYPE_BIN32:+      if (!ctx->read(ctx, &u32temp, sizeof(uint32_t))) {+        ctx->error = LENGTH_READING_ERROR;+        return false;+      }+      *size = be32(u32temp);+      return true;+    case CMP_TYPE_EXT8:+      if (!ctx->read(ctx, &u8temp, sizeof(uint8_t))) {+        ctx->error = LENGTH_READING_ERROR;+        return false;+      }+      *size = u8temp;+      return true;+    case CMP_TYPE_EXT16:+      if (!ctx->read(ctx, &u16temp, sizeof(uint16_t))) {+        ctx->error = LENGTH_READING_ERROR;+        return false;+      }+      *size = be16(u16temp);+      return true;+    case CMP_TYPE_EXT32:+      if (!ctx->read(ctx, &u32temp, sizeof(uint32_t))) {+        ctx->error = LENGTH_READING_ERROR;+        return false;+      }+      *size = be32(u32temp);+      return true;+    case CMP_TYPE_FLOAT:+      *size = 4;+      return true;+    case CMP_TYPE_DOUBLE:+      *size = 8;+      return true;+    case CMP_TYPE_UINT8:+      *size = 1;+      return true;+    case CMP_TYPE_UINT16:+      *size = 2;+      return true;+    case CMP_TYPE_UINT32:+      *size = 4;+      return true;+    case CMP_TYPE_UINT64:+      *size = 8;+      return true;+    case CMP_TYPE_SINT8:+      *size = 1;+      return true;+    case CMP_TYPE_SINT16:+      *size = 2;+      return true;+    case CMP_TYPE_SINT32:+      *size = 4;+      return true;+    case CMP_TYPE_SINT64:+      *size = 8;+      return true;+    case CMP_TYPE_FIXEXT1:+      *size = 1;+      return true;+    case CMP_TYPE_FIXEXT2:+      *size = 2;+      return true;+    case CMP_TYPE_FIXEXT4:+      *size = 4;+      return true;+    case CMP_TYPE_FIXEXT8:+      *size = 8;+      return true;+    case CMP_TYPE_FIXEXT16:+      *size = 16;+      return true;+    case CMP_TYPE_STR8:+      if (!ctx->read(ctx, &u8temp, sizeof(uint8_t))) {+        ctx->error = DATA_READING_ERROR;+        return false;+      }+      *size = u8temp;+      return true;+    case CMP_TYPE_STR16:+      if (!ctx->read(ctx, &u16temp, sizeof(uint16_t))) {+        ctx->error = DATA_READING_ERROR;+        return false;+      }+      *size = be16(u16temp);+      return true;+    case CMP_TYPE_STR32:+      if (!ctx->read(ctx, &u32temp, sizeof(uint32_t))) {+        ctx->error = DATA_READING_ERROR;+        return false;+      }+      *size = be32(u32temp);+      return true;+    case CMP_TYPE_ARRAY16:+      if (!ctx->read(ctx, &u16temp, sizeof(uint16_t))) {+        ctx->error = DATA_READING_ERROR;+        return false;+      }+      *size = be16(u16temp);+      return true;+    case CMP_TYPE_ARRAY32:+      if (!ctx->read(ctx, &u32temp, sizeof(uint32_t))) {+        ctx->error = DATA_READING_ERROR;+        return false;+      }+      *size = be32(u32temp);+      return true;+    case CMP_TYPE_MAP16:+      if (!ctx->read(ctx, &u16temp, sizeof(uint16_t))) {+        ctx->error = DATA_READING_ERROR;+        return false;+      }+      *size = be16(u16temp);+      return true;+    case CMP_TYPE_MAP32:+      if (!ctx->read(ctx, &u32temp, sizeof(uint32_t))) {+        ctx->error = DATA_READING_ERROR;+        return false;+      }+      *size = be32(u32temp);+      return true;+    case CMP_TYPE_NEGATIVE_FIXNUM:+      *size = 0;+      return true;+    default:+      ctx->error = INVALID_TYPE_ERROR;+      return false;+  }+}++static bool read_obj_data(cmp_ctx_t *ctx, uint8_t type_marker,+                                          cmp_object_t *obj) {+  switch (obj->type) {+    case CMP_TYPE_POSITIVE_FIXNUM:+      obj->as.u8 = type_marker;+      return true;+    case CMP_TYPE_NEGATIVE_FIXNUM:+      obj->as.s8 = (int8_t)type_marker;+      return true;+    case CMP_TYPE_NIL:+      obj->as.u8 = 0;+      return true;+    case CMP_TYPE_BOOLEAN:+      switch (type_marker) {+        case TRUE_MARKER:+          obj->as.boolean = true;+          return true;+        case FALSE_MARKER:+          obj->as.boolean = false;+          return true;+        default:+          break;+      }+      ctx->error = INTERNAL_ERROR;+      return false;+    case CMP_TYPE_UINT8:+      if (!ctx->read(ctx, &obj->as.u8, sizeof(uint8_t))) {+        ctx->error = DATA_READING_ERROR;+        return false;+      }+      return true;+    case CMP_TYPE_UINT16:+      if (!ctx->read(ctx, &obj->as.u16, sizeof(uint16_t))) {+        ctx->error = DATA_READING_ERROR;+        return false;+      }+      obj->as.u16 = be16(obj->as.u16);+      return true;+    case CMP_TYPE_UINT32:+      if (!ctx->read(ctx, &obj->as.u32, sizeof(uint32_t))) {+        ctx->error = DATA_READING_ERROR;+        return false;+      }+      obj->as.u32 = be32(obj->as.u32);+      return true;+    case CMP_TYPE_UINT64:+      if (!ctx->read(ctx, &obj->as.u64, sizeof(uint64_t))) {+        ctx->error = DATA_READING_ERROR;+        return false;+      }+      obj->as.u64 = be64(obj->as.u64);+      return true;+    case CMP_TYPE_SINT8:+      if (!ctx->read(ctx, &obj->as.s8, sizeof(int8_t))) {+        ctx->error = DATA_READING_ERROR;+        return false;+      }+      return true;+    case CMP_TYPE_SINT16:+      if (!ctx->read(ctx, &obj->as.s16, sizeof(int16_t))) {+        ctx->error = DATA_READING_ERROR;+        return false;+      }+      obj->as.s16 = sbe16(obj->as.s16);+      return true;+    case CMP_TYPE_SINT32:+      if (!ctx->read(ctx, &obj->as.s32, sizeof(int32_t))) {+        ctx->error = DATA_READING_ERROR;+        return false;+      }+      obj->as.s32 = sbe32(obj->as.s32);+      return true;+    case CMP_TYPE_SINT64:+      if (!ctx->read(ctx, &obj->as.s64, sizeof(int64_t))) {+        ctx->error = DATA_READING_ERROR;+        return false;+      }+      obj->as.s64 = sbe64(obj->as.s64);+      return true;+    case CMP_TYPE_FLOAT:+    {+#ifndef CMP_NO_FLOAT+      char bytes[4];++      if (!ctx->read(ctx, bytes, 4)) {+        ctx->error = DATA_READING_ERROR;+        return false;+      }+      obj->as.flt = decode_befloat(bytes);+      return true;+#else /* CMP_NO_FLOAT */+      ctx->error = DISABLED_FLOATING_POINT_ERROR;+      return false;+#endif /* CMP_NO_FLOAT */+    }+    case CMP_TYPE_DOUBLE:+    {+#ifndef CMP_NO_FLOAT+      char bytes[8];++      if (!ctx->read(ctx, bytes, 8)) {+        ctx->error = DATA_READING_ERROR;+        return false;+      }+      obj->as.dbl = decode_bedouble(bytes);+      return true;+#else /* CMP_NO_FLOAT */+      ctx->error = DISABLED_FLOATING_POINT_ERROR;+      return false;+#endif /* CMP_NO_FLOAT */+    }+    case CMP_TYPE_BIN8:+    case CMP_TYPE_BIN16:+    case CMP_TYPE_BIN32:+      return read_type_size(ctx, type_marker, obj->type, &obj->as.bin_size);+    case CMP_TYPE_FIXSTR:+    case CMP_TYPE_STR8:+    case CMP_TYPE_STR16:+    case CMP_TYPE_STR32:+      return read_type_size(ctx, type_marker, obj->type, &obj->as.str_size);+    case CMP_TYPE_FIXARRAY:+    case CMP_TYPE_ARRAY16:+    case CMP_TYPE_ARRAY32:+      return read_type_size(ctx, type_marker, obj->type, &obj->as.array_size);+    case CMP_TYPE_FIXMAP:+    case CMP_TYPE_MAP16:+    case CMP_TYPE_MAP32:+      return read_type_size(ctx, type_marker, obj->type, &obj->as.map_size);+    case CMP_TYPE_FIXEXT1:+      if (!ctx->read(ctx, &obj->as.ext.type, sizeof(int8_t))) {+        ctx->error = EXT_TYPE_READING_ERROR;+        return false;+      }+      obj->as.ext.size = 1;+      return true;+    case CMP_TYPE_FIXEXT2:+      if (!ctx->read(ctx, &obj->as.ext.type, sizeof(int8_t))) {+        ctx->error = EXT_TYPE_READING_ERROR;+        return false;+      }+      obj->as.ext.size = 2;+      return true;+    case CMP_TYPE_FIXEXT4:+      if (!ctx->read(ctx, &obj->as.ext.type, sizeof(int8_t))) {+        ctx->error = EXT_TYPE_READING_ERROR;+        return false;+      }+      obj->as.ext.size = 4;+      return true;+    case CMP_TYPE_FIXEXT8:+      if (!ctx->read(ctx, &obj->as.ext.type, sizeof(int8_t))) {+        ctx->error = EXT_TYPE_READING_ERROR;+        return false;+      }+      obj->as.ext.size = 8;+      return true;+    case CMP_TYPE_FIXEXT16:+      if (!ctx->read(ctx, &obj->as.ext.type, sizeof(int8_t))) {+        ctx->error = EXT_TYPE_READING_ERROR;+        return false;+      }+      obj->as.ext.size = 16;+      return true;+    case CMP_TYPE_EXT8:+      if (!read_type_size(ctx, type_marker, obj->type, &obj->as.ext.size)) {+        return false;+      }+      if (!ctx->read(ctx, &obj->as.ext.type, sizeof(int8_t))) {+        ctx->error = EXT_TYPE_READING_ERROR;+        return false;+      }+      return true;+    case CMP_TYPE_EXT16:+      if (!read_type_size(ctx, type_marker, obj->type, &obj->as.ext.size)) {+        return false;+      }+      if (!ctx->read(ctx, &obj->as.ext.type, sizeof(int8_t))) {+        ctx->error = EXT_TYPE_READING_ERROR;+        return false;+      }+      return true;+    case CMP_TYPE_EXT32:+      if (!read_type_size(ctx, type_marker, obj->type, &obj->as.ext.size)) {+        return false;+      }+      if (!ctx->read(ctx, &obj->as.ext.type, sizeof(int8_t))) {+        ctx->error = EXT_TYPE_READING_ERROR;+        return false;+      }+      return true;+    default:+      break;+  }++  ctx->error = INVALID_TYPE_ERROR;+  return false;+}++void cmp_init(cmp_ctx_t *ctx, void *buf, cmp_reader read,+                                         cmp_skipper skip,+                                         cmp_writer write) {+  ctx->error = ERROR_NONE;+  ctx->buf = buf;+  ctx->read = read;+  ctx->skip = skip;+  ctx->write = write;+}++uint32_t cmp_version(void) {+  return cmp_version_;+}++uint32_t cmp_mp_version(void) {+  return cmp_mp_version_;+}++const char* cmp_strerror(cmp_ctx_t *ctx) {+  if (ctx->error > ERROR_NONE && ctx->error < ERROR_MAX)+    return cmp_error_messages[ctx->error];++  return "";+}++bool cmp_write_pfix(cmp_ctx_t *ctx, uint8_t c) {+  if (c <= 0x7F)+    return write_fixed_value(ctx, c);++  ctx->error = INPUT_VALUE_TOO_LARGE_ERROR;+  return false;+}++bool cmp_write_nfix(cmp_ctx_t *ctx, int8_t c) {+  if (c >= -32 && c <= -1)+    return write_fixed_value(ctx, (uint8_t)c);++  ctx->error = INPUT_VALUE_TOO_LARGE_ERROR;+  return false;+}++bool cmp_write_sfix(cmp_ctx_t *ctx, int8_t c) {+  if (c >= 0)+    return cmp_write_pfix(ctx, (uint8_t)c);+  if (c >= -32 && c <= -1)+    return cmp_write_nfix(ctx, c);++  ctx->error = INPUT_VALUE_TOO_LARGE_ERROR;+  return false;+}++bool cmp_write_s8(cmp_ctx_t *ctx, int8_t c) {+  if (!write_type_marker(ctx, S8_MARKER))+    return false;++  return ctx->write(ctx, &c, sizeof(int8_t));+}++bool cmp_write_s16(cmp_ctx_t *ctx, int16_t s) {+  if (!write_type_marker(ctx, S16_MARKER))+    return false;++  s = sbe16(s);++  return ctx->write(ctx, &s, sizeof(int16_t));+}++bool cmp_write_s32(cmp_ctx_t *ctx, int32_t i) {+  if (!write_type_marker(ctx, S32_MARKER))+    return false;++  i = sbe32(i);++  return ctx->write(ctx, &i, sizeof(int32_t));+}++bool cmp_write_s64(cmp_ctx_t *ctx, int64_t l) {+  if (!write_type_marker(ctx, S64_MARKER))+    return false;++  l = sbe64(l);++  return ctx->write(ctx, &l, sizeof(int64_t));+}++bool cmp_write_integer(cmp_ctx_t *ctx, int64_t d) {+  if (d >= 0)+    return cmp_write_uinteger(ctx, (uint64_t)d);+  if (d >= -32)+    return cmp_write_nfix(ctx, (int8_t)d);+  if (d >= -128)+    return cmp_write_s8(ctx, (int8_t)d);+  if (d >= -32768)+    return cmp_write_s16(ctx, (int16_t)d);+  if (d >= (-2147483647 - 1))+    return cmp_write_s32(ctx, (int32_t)d);++  return cmp_write_s64(ctx, d);+}++bool cmp_write_ufix(cmp_ctx_t *ctx, uint8_t c) {+  return cmp_write_pfix(ctx, c);+}++bool cmp_write_u8(cmp_ctx_t *ctx, uint8_t c) {+  if (!write_type_marker(ctx, U8_MARKER))+    return false;++  return ctx->write(ctx, &c, sizeof(uint8_t));+}++bool cmp_write_u16(cmp_ctx_t *ctx, uint16_t s) {+  if (!write_type_marker(ctx, U16_MARKER))+    return false;++  s = be16(s);++  return ctx->write(ctx, &s, sizeof(uint16_t));+}++bool cmp_write_u32(cmp_ctx_t *ctx, uint32_t i) {+  if (!write_type_marker(ctx, U32_MARKER))+    return false;++  i = be32(i);++  return ctx->write(ctx, &i, sizeof(uint32_t));+}++bool cmp_write_u64(cmp_ctx_t *ctx, uint64_t l) {+  if (!write_type_marker(ctx, U64_MARKER))+    return false;++  l = be64(l);++  return ctx->write(ctx, &l, sizeof(uint64_t));+}++bool cmp_write_uinteger(cmp_ctx_t *ctx, uint64_t u) {+  if (u <= 0x7F)+    return cmp_write_pfix(ctx, (uint8_t)u);+  if (u <= 0xFF)+    return cmp_write_u8(ctx, (uint8_t)u);+  if (u <= 0xFFFF)+    return cmp_write_u16(ctx, (uint16_t)u);+  if (u <= 0xFFFFFFFF)+    return cmp_write_u32(ctx, (uint32_t)u);++  return cmp_write_u64(ctx, u);+}++#ifndef CMP_NO_FLOAT+bool cmp_write_float(cmp_ctx_t *ctx, float f) {+  if (!write_type_marker(ctx, FLOAT_MARKER))+    return false;++  /*+   * We may need to swap the float's bytes, but we can't just swap them inside+   * the float because the swapped bytes may not constitute a valid float.+   * Therefore, we have to create a buffer and swap the bytes there.+   */+  if (!is_bigendian()) {+    char swapped[sizeof(float)];+    char *fbuf = (char *)&f;+    size_t i;++    for (i = 0; i < sizeof(float); i++)+      swapped[i] = fbuf[sizeof(float) - i - 1];++    return ctx->write(ctx, swapped, sizeof(float));+  }++  return ctx->write(ctx, &f, sizeof(float));+}++bool cmp_write_double(cmp_ctx_t *ctx, double d) {+  if (!write_type_marker(ctx, DOUBLE_MARKER))+    return false;++  /* Same deal for doubles */+  if (!is_bigendian()) {+    char swapped[sizeof(double)];+    char *dbuf = (char *)&d;+    size_t i;++    for (i = 0; i < sizeof(double); i++)+      swapped[i] = dbuf[sizeof(double) - i - 1];++    return ctx->write(ctx, swapped, sizeof(double));+  }++  return ctx->write(ctx, &d, sizeof(double));+}++bool cmp_write_decimal(cmp_ctx_t *ctx, double d) {+  float f = (float)d;+  double df = (double)f;++  if (df == d)+    return cmp_write_float(ctx, f);+  else+    return cmp_write_double(ctx, d);+}+#endif /* CMP_NO_FLOAT */++bool cmp_write_nil(cmp_ctx_t *ctx) {+  return write_type_marker(ctx, NIL_MARKER);+}++bool cmp_write_true(cmp_ctx_t *ctx) {+  return write_type_marker(ctx, TRUE_MARKER);+}++bool cmp_write_false(cmp_ctx_t *ctx) {+  return write_type_marker(ctx, FALSE_MARKER);+}++bool cmp_write_bool(cmp_ctx_t *ctx, bool b) {+  if (b)+    return cmp_write_true(ctx);++  return cmp_write_false(ctx);+}++bool cmp_write_u8_as_bool(cmp_ctx_t *ctx, uint8_t b) {+  if (b)+    return cmp_write_true(ctx);++  return cmp_write_false(ctx);+}++bool cmp_write_fixstr_marker(cmp_ctx_t *ctx, uint8_t size) {+  if (size <= FIXSTR_SIZE)+    return write_fixed_value(ctx, FIXSTR_MARKER | size);++  ctx->error = INPUT_VALUE_TOO_LARGE_ERROR;+  return false;+}++bool cmp_write_fixstr(cmp_ctx_t *ctx, const char *data, uint8_t size) {+  if (!cmp_write_fixstr_marker(ctx, size))+    return false;++  if (size == 0)+    return true;++  if (ctx->write(ctx, data, size))+    return true;++  ctx->error = DATA_WRITING_ERROR;+  return false;+}++bool cmp_write_str8_marker(cmp_ctx_t *ctx, uint8_t size) {+  if (!write_type_marker(ctx, STR8_MARKER))+    return false;++  if (ctx->write(ctx, &size, sizeof(uint8_t)))+    return true;++  ctx->error = LENGTH_WRITING_ERROR;+  return false;+}++bool cmp_write_str8(cmp_ctx_t *ctx, const char *data, uint8_t size) {+  if (!cmp_write_str8_marker(ctx, size))+    return false;++  if (size == 0)+    return true;++  if (ctx->write(ctx, data, size))+    return true;++  ctx->error = DATA_WRITING_ERROR;+  return false;+}++bool cmp_write_str16_marker(cmp_ctx_t *ctx, uint16_t size) {+  if (!write_type_marker(ctx, STR16_MARKER))+    return false;++  size = be16(size);++  if (ctx->write(ctx, &size, sizeof(uint16_t)))+    return true;++  ctx->error = LENGTH_WRITING_ERROR;+  return false;+}++bool cmp_write_str16(cmp_ctx_t *ctx, const char *data, uint16_t size) {+  if (!cmp_write_str16_marker(ctx, size))+    return false;++  if (size == 0)+    return true;++  if (ctx->write(ctx, data, size))+    return true;++  ctx->error = DATA_WRITING_ERROR;+  return false;+}++bool cmp_write_str32_marker(cmp_ctx_t *ctx, uint32_t size) {+  if (!write_type_marker(ctx, STR32_MARKER))+    return false;++  size = be32(size);++  if (ctx->write(ctx, &size, sizeof(uint32_t)))+    return true;++  ctx->error = LENGTH_WRITING_ERROR;+  return false;+}++bool cmp_write_str32(cmp_ctx_t *ctx, const char *data, uint32_t size) {+  if (!cmp_write_str32_marker(ctx, size))+    return false;++  if (size == 0)+    return true;++  if (ctx->write(ctx, data, size))+    return true;++  ctx->error = DATA_WRITING_ERROR;+  return false;+}++bool cmp_write_str_marker(cmp_ctx_t *ctx, uint32_t size) {+  if (size <= FIXSTR_SIZE)+    return cmp_write_fixstr_marker(ctx, (uint8_t)size);+  if (size <= 0xFF)+    return cmp_write_str8_marker(ctx, (uint8_t)size);+  if (size <= 0xFFFF)+    return cmp_write_str16_marker(ctx, (uint16_t)size);++  return cmp_write_str32_marker(ctx, size);+}++bool cmp_write_str_marker_v4(cmp_ctx_t *ctx, uint32_t size) {+  if (size <= FIXSTR_SIZE)+    return cmp_write_fixstr_marker(ctx, (uint8_t)size);+  if (size <= 0xFFFF)+    return cmp_write_str16_marker(ctx, (uint16_t)size);++  return cmp_write_str32_marker(ctx, size);+}++bool cmp_write_str(cmp_ctx_t *ctx, const char *data, uint32_t size) {+  if (size <= FIXSTR_SIZE)+    return cmp_write_fixstr(ctx, data, (uint8_t)size);+  if (size <= 0xFF)+    return cmp_write_str8(ctx, data, (uint8_t)size);+  if (size <= 0xFFFF)+    return cmp_write_str16(ctx, data, (uint16_t)size);++  return cmp_write_str32(ctx, data, size);+}++bool cmp_write_str_v4(cmp_ctx_t *ctx, const char *data, uint32_t size) {+  if (size <= FIXSTR_SIZE)+    return cmp_write_fixstr(ctx, data, (uint8_t)size);+  if (size <= 0xFFFF)+    return cmp_write_str16(ctx, data, (uint16_t)size);++  return cmp_write_str32(ctx, data, size);+}++bool cmp_write_bin8_marker(cmp_ctx_t *ctx, uint8_t size) {+  if (!write_type_marker(ctx, BIN8_MARKER))+    return false;++  if (ctx->write(ctx, &size, sizeof(uint8_t)))+    return true;++  ctx->error = LENGTH_WRITING_ERROR;+  return false;+}++bool cmp_write_bin8(cmp_ctx_t *ctx, const void *data, uint8_t size) {+  if (!cmp_write_bin8_marker(ctx, size))+    return false;++  if (size == 0)+    return true;++  if (ctx->write(ctx, data, size))+    return true;++  ctx->error = DATA_WRITING_ERROR;+  return false;+}++bool cmp_write_bin16_marker(cmp_ctx_t *ctx, uint16_t size) {+  if (!write_type_marker(ctx, BIN16_MARKER))+    return false;++  size = be16(size);++  if (ctx->write(ctx, &size, sizeof(uint16_t)))+    return true;++  ctx->error = LENGTH_WRITING_ERROR;+  return false;+}++bool cmp_write_bin16(cmp_ctx_t *ctx, const void *data, uint16_t size) {+  if (!cmp_write_bin16_marker(ctx, size))+    return false;++  if (size == 0)+    return true;++  if (ctx->write(ctx, data, size))+    return true;++  ctx->error = DATA_WRITING_ERROR;+  return false;+}++bool cmp_write_bin32_marker(cmp_ctx_t *ctx, uint32_t size) {+  if (!write_type_marker(ctx, BIN32_MARKER))+    return false;++  size = be32(size);++  if (ctx->write(ctx, &size, sizeof(uint32_t)))+    return true;++  ctx->error = LENGTH_WRITING_ERROR;+  return false;+}++bool cmp_write_bin32(cmp_ctx_t *ctx, const void *data, uint32_t size) {+  if (!cmp_write_bin32_marker(ctx, size))+    return false;++  if (size == 0)+    return true;++  if (ctx->write(ctx, data, size))+    return true;++  ctx->error = DATA_WRITING_ERROR;+  return false;+}++bool cmp_write_bin_marker(cmp_ctx_t *ctx, uint32_t size) {+  if (size <= 0xFF)+    return cmp_write_bin8_marker(ctx, (uint8_t)size);+  if (size <= 0xFFFF)+    return cmp_write_bin16_marker(ctx, (uint16_t)size);++  return cmp_write_bin32_marker(ctx, size);+}++bool cmp_write_bin(cmp_ctx_t *ctx, const void *data, uint32_t size) {+  if (size <= 0xFF)+    return cmp_write_bin8(ctx, data, (uint8_t)size);+  if (size <= 0xFFFF)+    return cmp_write_bin16(ctx, data, (uint16_t)size);++  return cmp_write_bin32(ctx, data, size);+}++bool cmp_write_fixarray(cmp_ctx_t *ctx, uint8_t size) {+  if (size <= FIXARRAY_SIZE)+    return write_fixed_value(ctx, FIXARRAY_MARKER | size);++  ctx->error = INPUT_VALUE_TOO_LARGE_ERROR;+  return false;+}++bool cmp_write_array16(cmp_ctx_t *ctx, uint16_t size) {+  if (!write_type_marker(ctx, ARRAY16_MARKER))+    return false;++  size = be16(size);++  if (ctx->write(ctx, &size, sizeof(uint16_t)))+    return true;++  ctx->error = LENGTH_WRITING_ERROR;+  return false;+}++bool cmp_write_array32(cmp_ctx_t *ctx, uint32_t size) {+  if (!write_type_marker(ctx, ARRAY32_MARKER))+    return false;++  size = be32(size);++  if (ctx->write(ctx, &size, sizeof(uint32_t)))+    return true;++  ctx->error = LENGTH_WRITING_ERROR;+  return false;+}++bool cmp_write_array(cmp_ctx_t *ctx, uint32_t size) {+  if (size <= FIXARRAY_SIZE)+    return cmp_write_fixarray(ctx, (uint8_t)size);+  if (size <= 0xFFFF)+    return cmp_write_array16(ctx, (uint16_t)size);++  return cmp_write_array32(ctx, size);+}++bool cmp_write_fixmap(cmp_ctx_t *ctx, uint8_t size) {+  if (size <= FIXMAP_SIZE)+    return write_fixed_value(ctx, FIXMAP_MARKER | size);++  ctx->error = INPUT_VALUE_TOO_LARGE_ERROR;+  return false;+}++bool cmp_write_map16(cmp_ctx_t *ctx, uint16_t size) {+  if (!write_type_marker(ctx, MAP16_MARKER))+    return false;++  size = be16(size);++  if (ctx->write(ctx, &size, sizeof(uint16_t)))+    return true;++  ctx->error = LENGTH_WRITING_ERROR;+  return false;+}++bool cmp_write_map32(cmp_ctx_t *ctx, uint32_t size) {+  if (!write_type_marker(ctx, MAP32_MARKER))+    return false;++  size = be32(size);++  if (ctx->write(ctx, &size, sizeof(uint32_t)))+    return true;++  ctx->error = LENGTH_WRITING_ERROR;+  return false;+}++bool cmp_write_map(cmp_ctx_t *ctx, uint32_t size) {+  if (size <= FIXMAP_SIZE)+    return cmp_write_fixmap(ctx, (uint8_t)size);+  if (size <= 0xFFFF)+    return cmp_write_map16(ctx, (uint16_t)size);++  return cmp_write_map32(ctx, size);+}++bool cmp_write_fixext1_marker(cmp_ctx_t *ctx, int8_t type) {+  if (!write_type_marker(ctx, FIXEXT1_MARKER))+    return false;++  if (ctx->write(ctx, &type, sizeof(int8_t)))+    return true;++  ctx->error = EXT_TYPE_WRITING_ERROR;+  return false;+}++bool cmp_write_fixext1(cmp_ctx_t *ctx, int8_t type, const void *data) {+  if (!cmp_write_fixext1_marker(ctx, type))+    return false;++  if (ctx->write(ctx, data, 1))+    return true;++  ctx->error = DATA_WRITING_ERROR;+  return false;+}++bool cmp_write_fixext2_marker(cmp_ctx_t *ctx, int8_t type) {+  if (!write_type_marker(ctx, FIXEXT2_MARKER))+    return false;++  if (ctx->write(ctx, &type, sizeof(int8_t)))+    return true;++  ctx->error = EXT_TYPE_WRITING_ERROR;+  return false;+}++bool cmp_write_fixext2(cmp_ctx_t *ctx, int8_t type, const void *data) {+  if (!cmp_write_fixext2_marker(ctx, type))+    return false;++  if (ctx->write(ctx, data, 2))+    return true;++  ctx->error = DATA_WRITING_ERROR;+  return false;+}++bool cmp_write_fixext4_marker(cmp_ctx_t *ctx, int8_t type) {+  if (!write_type_marker(ctx, FIXEXT4_MARKER))+    return false;++  if (ctx->write(ctx, &type, sizeof(int8_t)))+    return true;++  ctx->error = EXT_TYPE_WRITING_ERROR;+  return false;+}++bool cmp_write_fixext4(cmp_ctx_t *ctx, int8_t type, const void *data) {+  if (!cmp_write_fixext4_marker(ctx, type))+    return false;++  if (ctx->write(ctx, data, 4))+    return true;++  ctx->error = DATA_WRITING_ERROR;+  return false;+}++bool cmp_write_fixext8_marker(cmp_ctx_t *ctx, int8_t type) {+  if (!write_type_marker(ctx, FIXEXT8_MARKER))+    return false;++  if (ctx->write(ctx, &type, sizeof(int8_t)))+    return true;++  ctx->error = EXT_TYPE_WRITING_ERROR;+  return false;+}++bool cmp_write_fixext8(cmp_ctx_t *ctx, int8_t type, const void *data) {+  if (!cmp_write_fixext8_marker(ctx, type))+    return false;++  if (ctx->write(ctx, data, 8))+    return true;++  ctx->error = DATA_WRITING_ERROR;+  return false;+}++bool cmp_write_fixext16_marker(cmp_ctx_t *ctx, int8_t type) {+  if (!write_type_marker(ctx, FIXEXT16_MARKER))+    return false;++  if (ctx->write(ctx, &type, sizeof(int8_t)))+    return true;++  ctx->error = EXT_TYPE_WRITING_ERROR;+  return false;+}++bool cmp_write_fixext16(cmp_ctx_t *ctx, int8_t type, const void *data) {+  if (!cmp_write_fixext16_marker(ctx, type))+    return false;++  if (ctx->write(ctx, data, 16))+    return true;++  ctx->error = DATA_WRITING_ERROR;+  return false;+}++bool cmp_write_ext8_marker(cmp_ctx_t *ctx, int8_t type, uint8_t size) {+  if (!write_type_marker(ctx, EXT8_MARKER))+    return false;++  if (!ctx->write(ctx, &size, sizeof(uint8_t))) {+    ctx->error = LENGTH_WRITING_ERROR;+    return false;+  }++  if (ctx->write(ctx, &type, sizeof(int8_t)))+    return true;++  ctx->error = EXT_TYPE_WRITING_ERROR;+  return false;+}++bool cmp_write_ext8(cmp_ctx_t *ctx, int8_t type, uint8_t size, const void *data) {+  if (!cmp_write_ext8_marker(ctx, type, size))+    return false;++  if (ctx->write(ctx, data, size))+    return true;++  ctx->error = DATA_WRITING_ERROR;+  return false;+}++bool cmp_write_ext16_marker(cmp_ctx_t *ctx, int8_t type, uint16_t size) {+  if (!write_type_marker(ctx, EXT16_MARKER))+    return false;++  size = be16(size);++  if (!ctx->write(ctx, &size, sizeof(uint16_t))) {+    ctx->error = LENGTH_WRITING_ERROR;+    return false;+  }++  if (ctx->write(ctx, &type, sizeof(int8_t)))+    return true;++  ctx->error = EXT_TYPE_WRITING_ERROR;+  return false;+}++bool cmp_write_ext16(cmp_ctx_t *ctx, int8_t type, uint16_t size, const void *data) {+  if (!cmp_write_ext16_marker(ctx, type, size))+    return false;++  if (ctx->write(ctx, data, size))+    return true;++  ctx->error = DATA_WRITING_ERROR;+  return false;+}++bool cmp_write_ext32_marker(cmp_ctx_t *ctx, int8_t type, uint32_t size) {+  if (!write_type_marker(ctx, EXT32_MARKER))+    return false;++  size = be32(size);++  if (!ctx->write(ctx, &size, sizeof(uint32_t))) {+    ctx->error = LENGTH_WRITING_ERROR;+    return false;+  }++  if (ctx->write(ctx, &type, sizeof(int8_t)))+    return true;++  ctx->error = EXT_TYPE_WRITING_ERROR;+  return false;+}++bool cmp_write_ext32(cmp_ctx_t *ctx, int8_t type, uint32_t size, const void *data) {+  if (!cmp_write_ext32_marker(ctx, type, size))+    return false;++  if (ctx->write(ctx, data, size))+    return true;++  ctx->error = DATA_WRITING_ERROR;+  return false;+}++bool cmp_write_ext_marker(cmp_ctx_t *ctx, int8_t type, uint32_t size) {+  if (size == 1)+    return cmp_write_fixext1_marker(ctx, type);+  if (size == 2)+    return cmp_write_fixext2_marker(ctx, type);+  if (size == 4)+    return cmp_write_fixext4_marker(ctx, type);+  if (size == 8)+    return cmp_write_fixext8_marker(ctx, type);+  if (size == 16)+    return cmp_write_fixext16_marker(ctx, type);+  if (size <= 0xFF)+    return cmp_write_ext8_marker(ctx, type, (uint8_t)size);+  if (size <= 0xFFFF)+    return cmp_write_ext16_marker(ctx, type, (uint16_t)size);++  return cmp_write_ext32_marker(ctx, type, size);+}++bool cmp_write_ext(cmp_ctx_t *ctx, int8_t type, uint32_t size, const void *data) {+  if (size == 1)+    return cmp_write_fixext1(ctx, type, data);+  if (size == 2)+    return cmp_write_fixext2(ctx, type, data);+  if (size == 4)+    return cmp_write_fixext4(ctx, type, data);+  if (size == 8)+    return cmp_write_fixext8(ctx, type, data);+  if (size == 16)+    return cmp_write_fixext16(ctx, type, data);+  if (size <= 0xFF)+    return cmp_write_ext8(ctx, type, (uint8_t)size, data);+  if (size <= 0xFFFF)+    return cmp_write_ext16(ctx, type, (uint16_t)size, data);++  return cmp_write_ext32(ctx, type, size, data);+}++bool cmp_write_object(cmp_ctx_t *ctx, const cmp_object_t *obj) {+  switch(obj->type) {+    case CMP_TYPE_POSITIVE_FIXNUM:+      return cmp_write_pfix(ctx, obj->as.u8);+    case CMP_TYPE_FIXMAP:+      return cmp_write_fixmap(ctx, (uint8_t)obj->as.map_size);+    case CMP_TYPE_FIXARRAY:+      return cmp_write_fixarray(ctx, (uint8_t)obj->as.array_size);+    case CMP_TYPE_FIXSTR:+      return cmp_write_fixstr_marker(ctx, (uint8_t)obj->as.str_size);+    case CMP_TYPE_NIL:+      return cmp_write_nil(ctx);+    case CMP_TYPE_BOOLEAN:+      if (obj->as.boolean)+        return cmp_write_true(ctx);+      return cmp_write_false(ctx);+    case CMP_TYPE_BIN8:+      return cmp_write_bin8_marker(ctx, (uint8_t)obj->as.bin_size);+    case CMP_TYPE_BIN16:+      return cmp_write_bin16_marker(ctx, (uint16_t)obj->as.bin_size);+    case CMP_TYPE_BIN32:+      return cmp_write_bin32_marker(ctx, obj->as.bin_size);+    case CMP_TYPE_EXT8:+      return cmp_write_ext8_marker(+        ctx, obj->as.ext.type, (uint8_t)obj->as.ext.size+      );+    case CMP_TYPE_EXT16:+      return cmp_write_ext16_marker(+        ctx, obj->as.ext.type, (uint16_t)obj->as.ext.size+      );+    case CMP_TYPE_EXT32:+      return cmp_write_ext32_marker(ctx, obj->as.ext.type, obj->as.ext.size);+    case CMP_TYPE_FLOAT:+#ifndef CMP_NO_FLOAT+      return cmp_write_float(ctx, obj->as.flt);+#else /* CMP_NO_FLOAT */+      ctx->error = DISABLED_FLOATING_POINT_ERROR;+      return false;+#endif /* CMP_NO_FLOAT */+    case CMP_TYPE_DOUBLE:+#ifndef CMP_NO_FLOAT+      return cmp_write_double(ctx, obj->as.dbl);+#else /* CMP_NO_FLOAT */+      ctx->error = DISABLED_FLOATING_POINT_ERROR;+      return false;+#endif+    case CMP_TYPE_UINT8:+      return cmp_write_u8(ctx, obj->as.u8);+    case CMP_TYPE_UINT16:+      return cmp_write_u16(ctx, obj->as.u16);+    case CMP_TYPE_UINT32:+      return cmp_write_u32(ctx, obj->as.u32);+    case CMP_TYPE_UINT64:+      return cmp_write_u64(ctx, obj->as.u64);+    case CMP_TYPE_SINT8:+      return cmp_write_s8(ctx, obj->as.s8);+    case CMP_TYPE_SINT16:+      return cmp_write_s16(ctx, obj->as.s16);+    case CMP_TYPE_SINT32:+      return cmp_write_s32(ctx, obj->as.s32);+    case CMP_TYPE_SINT64:+      return cmp_write_s64(ctx, obj->as.s64);+    case CMP_TYPE_FIXEXT1:+      return cmp_write_fixext1_marker(ctx, obj->as.ext.type);+    case CMP_TYPE_FIXEXT2:+      return cmp_write_fixext2_marker(ctx, obj->as.ext.type);+    case CMP_TYPE_FIXEXT4:+      return cmp_write_fixext4_marker(ctx, obj->as.ext.type);+    case CMP_TYPE_FIXEXT8:+      return cmp_write_fixext8_marker(ctx, obj->as.ext.type);+    case CMP_TYPE_FIXEXT16:+      return cmp_write_fixext16_marker(ctx, obj->as.ext.type);+    case CMP_TYPE_STR8:+      return cmp_write_str8_marker(ctx, (uint8_t)obj->as.str_size);+    case CMP_TYPE_STR16:+      return cmp_write_str16_marker(ctx, (uint16_t)obj->as.str_size);+    case CMP_TYPE_STR32:+      return cmp_write_str32_marker(ctx, obj->as.str_size);+    case CMP_TYPE_ARRAY16:+      return cmp_write_array16(ctx, (uint16_t)obj->as.array_size);+    case CMP_TYPE_ARRAY32:+      return cmp_write_array32(ctx, obj->as.array_size);+    case CMP_TYPE_MAP16:+      return cmp_write_map16(ctx, (uint16_t)obj->as.map_size);+    case CMP_TYPE_MAP32:+      return cmp_write_map32(ctx, obj->as.map_size);+    case CMP_TYPE_NEGATIVE_FIXNUM:+      return cmp_write_nfix(ctx, obj->as.s8);+    default:+      ctx->error = INVALID_TYPE_ERROR;+      return false;+  }+}++bool cmp_write_object_v4(cmp_ctx_t *ctx, const cmp_object_t *obj) {+  switch(obj->type) {+    case CMP_TYPE_POSITIVE_FIXNUM:+      return cmp_write_pfix(ctx, obj->as.u8);+    case CMP_TYPE_FIXMAP:+      return cmp_write_fixmap(ctx, (uint8_t)obj->as.map_size);+    case CMP_TYPE_FIXARRAY:+      return cmp_write_fixarray(ctx, (uint8_t)obj->as.array_size);+    case CMP_TYPE_FIXSTR:+      return cmp_write_fixstr_marker(ctx, (uint8_t)obj->as.str_size);+    case CMP_TYPE_NIL:+      return cmp_write_nil(ctx);+    case CMP_TYPE_BOOLEAN:+      if (obj->as.boolean)+        return cmp_write_true(ctx);+      return cmp_write_false(ctx);+    case CMP_TYPE_EXT8:+      return cmp_write_ext8_marker(ctx, obj->as.ext.type, (uint8_t)obj->as.ext.size);+    case CMP_TYPE_EXT16:+      return cmp_write_ext16_marker(+        ctx, obj->as.ext.type, (uint16_t)obj->as.ext.size+      );+    case CMP_TYPE_EXT32:+      return cmp_write_ext32_marker(ctx, obj->as.ext.type, obj->as.ext.size);+    case CMP_TYPE_FLOAT:+#ifndef CMP_NO_FLOAT+      return cmp_write_float(ctx, obj->as.flt);+#else /* CMP_NO_FLOAT */+      ctx->error = DISABLED_FLOATING_POINT_ERROR;+      return false;+#endif+    case CMP_TYPE_DOUBLE:+#ifndef CMP_NO_FLOAT+      return cmp_write_double(ctx, obj->as.dbl);+#else+      ctx->error = DISABLED_FLOATING_POINT_ERROR;+      return false;+#endif+    case CMP_TYPE_UINT8:+      return cmp_write_u8(ctx, obj->as.u8);+    case CMP_TYPE_UINT16:+      return cmp_write_u16(ctx, obj->as.u16);+    case CMP_TYPE_UINT32:+      return cmp_write_u32(ctx, obj->as.u32);+    case CMP_TYPE_UINT64:+      return cmp_write_u64(ctx, obj->as.u64);+    case CMP_TYPE_SINT8:+      return cmp_write_s8(ctx, obj->as.s8);+    case CMP_TYPE_SINT16:+      return cmp_write_s16(ctx, obj->as.s16);+    case CMP_TYPE_SINT32:+      return cmp_write_s32(ctx, obj->as.s32);+    case CMP_TYPE_SINT64:+      return cmp_write_s64(ctx, obj->as.s64);+    case CMP_TYPE_FIXEXT1:+      return cmp_write_fixext1_marker(ctx, obj->as.ext.type);+    case CMP_TYPE_FIXEXT2:+      return cmp_write_fixext2_marker(ctx, obj->as.ext.type);+    case CMP_TYPE_FIXEXT4:+      return cmp_write_fixext4_marker(ctx, obj->as.ext.type);+    case CMP_TYPE_FIXEXT8:+      return cmp_write_fixext8_marker(ctx, obj->as.ext.type);+    case CMP_TYPE_FIXEXT16:+      return cmp_write_fixext16_marker(ctx, obj->as.ext.type);+    case CMP_TYPE_STR16:+      return cmp_write_str16_marker(ctx, (uint16_t)obj->as.str_size);+    case CMP_TYPE_STR32:+      return cmp_write_str32_marker(ctx, obj->as.str_size);+    case CMP_TYPE_ARRAY16:+      return cmp_write_array16(ctx, (uint16_t)obj->as.array_size);+    case CMP_TYPE_ARRAY32:+      return cmp_write_array32(ctx, obj->as.array_size);+    case CMP_TYPE_MAP16:+      return cmp_write_map16(ctx, (uint16_t)obj->as.map_size);+    case CMP_TYPE_MAP32:+      return cmp_write_map32(ctx, obj->as.map_size);+    case CMP_TYPE_NEGATIVE_FIXNUM:+      return cmp_write_nfix(ctx, obj->as.s8);+    default:+      ctx->error = INVALID_TYPE_ERROR;+      return false;+  }+}++bool cmp_read_pfix(cmp_ctx_t *ctx, uint8_t *c) {+  cmp_object_t obj;++  if (!cmp_read_object(ctx, &obj))+    return false;++  if (obj.type != CMP_TYPE_POSITIVE_FIXNUM) {+    ctx->error = INVALID_TYPE_ERROR;+    return false;+  }++  *c = obj.as.u8;+  return true;+}++bool cmp_read_nfix(cmp_ctx_t *ctx, int8_t *c) {+  cmp_object_t obj;++  if (!cmp_read_object(ctx, &obj))+    return false;++  if (obj.type != CMP_TYPE_NEGATIVE_FIXNUM) {+    ctx->error = INVALID_TYPE_ERROR;+    return false;+  }++  *c = obj.as.s8;+  return true;+}++bool cmp_read_sfix(cmp_ctx_t *ctx, int8_t *c) {+  cmp_object_t obj;++  if (!cmp_read_object(ctx, &obj))+    return false;++  switch (obj.type) {+    case CMP_TYPE_POSITIVE_FIXNUM:+    case CMP_TYPE_NEGATIVE_FIXNUM:+      *c = obj.as.s8;+      return true;+    default:+      ctx->error = INVALID_TYPE_ERROR;+      return false;+  }+}++bool cmp_read_s8(cmp_ctx_t *ctx, int8_t *c) {+  cmp_object_t obj;++  if (!cmp_read_object(ctx, &obj))+    return false;++  if (obj.type != CMP_TYPE_SINT8) {+    ctx->error = INVALID_TYPE_ERROR;+    return false;+  }++  *c = obj.as.s8;+  return true;+}++bool cmp_read_s16(cmp_ctx_t *ctx, int16_t *s) {+  cmp_object_t obj;++  if (!cmp_read_object(ctx, &obj))+    return false;++  if (obj.type != CMP_TYPE_SINT16) {+    ctx->error = INVALID_TYPE_ERROR;+    return false;+  }++  *s = obj.as.s16;+  return true;+}++bool cmp_read_s32(cmp_ctx_t *ctx, int32_t *i) {+  cmp_object_t obj;++  if (!cmp_read_object(ctx, &obj))+    return false;++  if (obj.type != CMP_TYPE_SINT32) {+    ctx->error = INVALID_TYPE_ERROR;+    return false;+  }++  *i = obj.as.s32;+  return true;+}++bool cmp_read_s64(cmp_ctx_t *ctx, int64_t *l) {+  cmp_object_t obj;++  if (!cmp_read_object(ctx, &obj))+    return false;++  if (obj.type != CMP_TYPE_SINT64) {+    ctx->error = INVALID_TYPE_ERROR;+    return false;+  }++  *l = obj.as.s64;+  return true;+}++bool cmp_read_char(cmp_ctx_t *ctx, int8_t *c) {+  cmp_object_t obj;++  if (!cmp_read_object(ctx, &obj))+    return false;++  switch (obj.type) {+    case CMP_TYPE_POSITIVE_FIXNUM:+    case CMP_TYPE_NEGATIVE_FIXNUM:+    case CMP_TYPE_SINT8:+      *c = obj.as.s8;+      return true;+    case CMP_TYPE_UINT8:+      if (obj.as.u8 <= 127) {+        *c = (int8_t)obj.as.u8;+        return true;+      }+      break;+    default:+      break;+  }++  ctx->error = INVALID_TYPE_ERROR;+  return false;+}++bool cmp_read_short(cmp_ctx_t *ctx, int16_t *s) {+  cmp_object_t obj;++  if (!cmp_read_object(ctx, &obj))+    return false;++  switch (obj.type) {+    case CMP_TYPE_POSITIVE_FIXNUM:+    case CMP_TYPE_NEGATIVE_FIXNUM:+    case CMP_TYPE_SINT8:+      *s = obj.as.s8;+      return true;+    case CMP_TYPE_UINT8:+      *s = obj.as.u8;+      return true;+    case CMP_TYPE_SINT16:+      *s = obj.as.s16;+      return true;+    case CMP_TYPE_UINT16:+      if (obj.as.u16 <= 32767) {+        *s = (int16_t)obj.as.u16;+        return true;+      }+      break;+    default:+      break;+  }++  ctx->error = INVALID_TYPE_ERROR;+  return false;+}++bool cmp_read_int(cmp_ctx_t *ctx, int32_t *i) {+  cmp_object_t obj;++  if (!cmp_read_object(ctx, &obj))+    return false;++  switch (obj.type) {+    case CMP_TYPE_POSITIVE_FIXNUM:+    case CMP_TYPE_NEGATIVE_FIXNUM:+    case CMP_TYPE_SINT8:+      *i = obj.as.s8;+      return true;+    case CMP_TYPE_UINT8:+      *i = obj.as.u8;+      return true;+    case CMP_TYPE_SINT16:+      *i = obj.as.s16;+      return true;+    case CMP_TYPE_UINT16:+      *i = obj.as.u16;+      return true;+    case CMP_TYPE_SINT32:+      *i = obj.as.s32;+      return true;+    case CMP_TYPE_UINT32:+      if (obj.as.u32 <= 2147483647) {+        *i = (int32_t)obj.as.u32;+        return true;+      }+      break;+    default:+      break;+  }++  ctx->error = INVALID_TYPE_ERROR;+  return false;+}++bool cmp_read_long(cmp_ctx_t *ctx, int64_t *d) {+  cmp_object_t obj;++  if (!cmp_read_object(ctx, &obj))+    return false;++  switch (obj.type) {+    case CMP_TYPE_POSITIVE_FIXNUM:+    case CMP_TYPE_NEGATIVE_FIXNUM:+    case CMP_TYPE_SINT8:+      *d = obj.as.s8;+      return true;+    case CMP_TYPE_UINT8:+      *d = obj.as.u8;+      return true;+    case CMP_TYPE_SINT16:+      *d = obj.as.s16;+      return true;+    case CMP_TYPE_UINT16:+      *d = obj.as.u16;+      return true;+    case CMP_TYPE_SINT32:+      *d = obj.as.s32;+      return true;+    case CMP_TYPE_UINT32:+      *d = obj.as.u32;+      return true;+    case CMP_TYPE_SINT64:+      *d = obj.as.s64;+      return true;+    case CMP_TYPE_UINT64:+      if (obj.as.u64 <= 9223372036854775807) {+        *d = (int64_t)obj.as.u64;+        return true;+      }+      break;+    default:+      break;+  }++  ctx->error = INVALID_TYPE_ERROR;+  return false;+}++bool cmp_read_integer(cmp_ctx_t *ctx, int64_t *d) {+  return cmp_read_long(ctx, d);+}++bool cmp_read_ufix(cmp_ctx_t *ctx, uint8_t *c) {+  return cmp_read_pfix(ctx, c);+}++bool cmp_read_u8(cmp_ctx_t *ctx, uint8_t *c) {+  cmp_object_t obj;++  if (!cmp_read_object(ctx, &obj))+    return false;++  if (obj.type != CMP_TYPE_UINT8) {+    ctx->error = INVALID_TYPE_ERROR;+    return false;+  }++  *c = obj.as.u8;+  return true;+}++bool cmp_read_u16(cmp_ctx_t *ctx, uint16_t *s) {+  cmp_object_t obj;++  if (!cmp_read_object(ctx, &obj))+    return false;++  if (obj.type != CMP_TYPE_UINT16) {+    ctx->error = INVALID_TYPE_ERROR;+    return false;+  }++  *s = obj.as.u16;+  return true;+}++bool cmp_read_u32(cmp_ctx_t *ctx, uint32_t *i) {+  cmp_object_t obj;++  if (!cmp_read_object(ctx, &obj))+    return false;++  if (obj.type != CMP_TYPE_UINT32) {+    ctx->error = INVALID_TYPE_ERROR;+    return false;+  }++  *i = obj.as.u32;+  return true;+}++bool cmp_read_u64(cmp_ctx_t *ctx, uint64_t *l) {+  cmp_object_t obj;++  if (!cmp_read_object(ctx, &obj))+    return false;++  if (obj.type != CMP_TYPE_UINT64) {+    ctx->error = INVALID_TYPE_ERROR;+    return false;+  }++  *l = obj.as.u64;+  return true;+}++bool cmp_read_uchar(cmp_ctx_t *ctx, uint8_t *c) {+  cmp_object_t obj;++  if (!cmp_read_object(ctx, &obj))+    return false;++  switch (obj.type) {+    case CMP_TYPE_POSITIVE_FIXNUM:+    case CMP_TYPE_UINT8:+      *c = obj.as.u8;+      return true;+    case CMP_TYPE_NEGATIVE_FIXNUM:+    case CMP_TYPE_SINT8:+      if (obj.as.s8 >= 0) {+        *c = (uint8_t)obj.as.s8;+        return true;+      }+      break;+    default:+      break;+  }++  ctx->error = INVALID_TYPE_ERROR;+  return false;+}++bool cmp_read_ushort(cmp_ctx_t *ctx, uint16_t *s) {+  cmp_object_t obj;++  if (!cmp_read_object(ctx, &obj))+    return false;++  switch (obj.type) {+    case CMP_TYPE_POSITIVE_FIXNUM:+    case CMP_TYPE_UINT8:+      *s = obj.as.u8;+      return true;+    case CMP_TYPE_UINT16:+      *s = obj.as.u16;+      return true;+    case CMP_TYPE_NEGATIVE_FIXNUM:+    case CMP_TYPE_SINT8:+      if (obj.as.s8 >= 0) {+        *s = (uint8_t)obj.as.s8;+        return true;+      }+      break;+    case CMP_TYPE_SINT16:+      if (obj.as.s16 >= 0) {+        *s = (uint16_t)obj.as.s16;+        return true;+      }+      break;+    default:+      break;+  }++  ctx->error = INVALID_TYPE_ERROR;+  return false;+}++bool cmp_read_uint(cmp_ctx_t *ctx, uint32_t *i) {+  cmp_object_t obj;++  if (!cmp_read_object(ctx, &obj))+    return false;++  switch (obj.type) {+    case CMP_TYPE_POSITIVE_FIXNUM:+    case CMP_TYPE_UINT8:+      *i = obj.as.u8;+      return true;+    case CMP_TYPE_UINT16:+      *i = obj.as.u16;+      return true;+    case CMP_TYPE_UINT32:+      *i = obj.as.u32;+      return true;+    case CMP_TYPE_NEGATIVE_FIXNUM:+    case CMP_TYPE_SINT8:+      if (obj.as.s8 >= 0) {+        *i = (uint8_t)obj.as.s8;+        return true;+      }+      break;+    case CMP_TYPE_SINT16:+      if (obj.as.s16 >= 0) {+        *i = (uint16_t)obj.as.s16;+        return true;+      }+      break;+    case CMP_TYPE_SINT32:+      if (obj.as.s32 >= 0) {+        *i = (uint32_t)obj.as.s32;+        return true;+      }+      break;+    default:+      break;+  }++  ctx->error = INVALID_TYPE_ERROR;+  return false;+}++bool cmp_read_ulong(cmp_ctx_t *ctx, uint64_t *u) {+  cmp_object_t obj;++  if (!cmp_read_object(ctx, &obj))+    return false;++  switch (obj.type) {+    case CMP_TYPE_POSITIVE_FIXNUM:+    case CMP_TYPE_UINT8:+      *u = obj.as.u8;+      return true;+    case CMP_TYPE_UINT16:+      *u = obj.as.u16;+      return true;+    case CMP_TYPE_UINT32:+      *u = obj.as.u32;+      return true;+    case CMP_TYPE_UINT64:+      *u = obj.as.u64;+      return true;+    case CMP_TYPE_NEGATIVE_FIXNUM:+    case CMP_TYPE_SINT8:+      if (obj.as.s8 >= 0) {+        *u = (uint8_t)obj.as.s8;+        return true;+      }+      break;+    case CMP_TYPE_SINT16:+      if (obj.as.s16 >= 0) {+        *u = (uint16_t)obj.as.s16;+        return true;+      }+      break;+    case CMP_TYPE_SINT32:+      if (obj.as.s32 >= 0) {+        *u = (uint32_t)obj.as.s32;+        return true;+      }+      break;+    case CMP_TYPE_SINT64:+      if (obj.as.s64 >= 0) {+        *u = (uint64_t)obj.as.s64;+        return true;+      }+      break;+    default:+      break;+  }++  ctx->error = INVALID_TYPE_ERROR;+  return false;+}++bool cmp_read_uinteger(cmp_ctx_t *ctx, uint64_t *u) {+  return cmp_read_ulong(ctx, u);+}++#ifndef CMP_NO_FLOAT+bool cmp_read_float(cmp_ctx_t *ctx, float *f) {+  cmp_object_t obj;++  if (!cmp_read_object(ctx, &obj))+    return false;++  if (obj.type != CMP_TYPE_FLOAT) {+    ctx->error = INVALID_TYPE_ERROR;+    return false;+  }++  *f = obj.as.flt;++  return true;+}++bool cmp_read_double(cmp_ctx_t *ctx, double *d) {+  cmp_object_t obj;++  if (!cmp_read_object(ctx, &obj))+    return false;++  if (obj.type != CMP_TYPE_DOUBLE) {+    ctx->error = INVALID_TYPE_ERROR;+    return false;+  }++  *d = obj.as.dbl;++  return true;+}++bool cmp_read_decimal(cmp_ctx_t *ctx, double *d) {+  cmp_object_t obj;++  if (!cmp_read_object(ctx, &obj))+    return false;++  switch (obj.type) {+    case CMP_TYPE_FLOAT:+      *d = (double)obj.as.flt;+      return true;+    case CMP_TYPE_DOUBLE:+      *d = obj.as.dbl;+      return true;+    default:+      ctx->error = INVALID_TYPE_ERROR;+      return false;+  }+}+#endif /* CMP_NO_FLOAT */++bool cmp_read_nil(cmp_ctx_t *ctx) {+  cmp_object_t obj;++  if (!cmp_read_object(ctx, &obj))+    return false;++  if (obj.type == CMP_TYPE_NIL)+    return true;++  ctx->error = INVALID_TYPE_ERROR;+  return false;+}++bool cmp_read_bool(cmp_ctx_t *ctx, bool *b) {+  cmp_object_t obj;++  if (!cmp_read_object(ctx, &obj))+    return false;++  if (obj.type != CMP_TYPE_BOOLEAN) {+    ctx->error = INVALID_TYPE_ERROR;+    return false;+  }++  if (obj.as.boolean)+    *b = true;+  else+    *b = false;++  return true;+}++bool cmp_read_bool_as_u8(cmp_ctx_t *ctx, uint8_t *b) {+  cmp_object_t obj;++  if (!cmp_read_object(ctx, &obj))+    return false;++  if (obj.type != CMP_TYPE_BOOLEAN) {+    ctx->error = INVALID_TYPE_ERROR;+    return false;+  }++  if (obj.as.boolean)+    *b = 1;+  else+    *b = 0;++  return true;+}++bool cmp_read_str_size(cmp_ctx_t *ctx, uint32_t *size) {+  cmp_object_t obj;++  if (!cmp_read_object(ctx, &obj))+    return false;++  switch (obj.type) {+    case CMP_TYPE_FIXSTR:+    case CMP_TYPE_STR8:+    case CMP_TYPE_STR16:+    case CMP_TYPE_STR32:+      *size = obj.as.str_size;+      return true;+    default:+      ctx->error = INVALID_TYPE_ERROR;+      return false;+  }+}++bool cmp_read_str(cmp_ctx_t *ctx, char *data, uint32_t *size) {+  uint32_t str_size = 0;++  if (!cmp_read_str_size(ctx, &str_size))+    return false;++  if (str_size >= *size) {+    *size = str_size;+    ctx->error = STR_DATA_LENGTH_TOO_LONG_ERROR;+    return false;+  }++  if (!ctx->read(ctx, data, str_size)) {+    ctx->error = DATA_READING_ERROR;+    return false;+  }++  data[str_size] = 0;++  *size = str_size;+  return true;+}++bool cmp_read_bin_size(cmp_ctx_t *ctx, uint32_t *size) {+  cmp_object_t obj;++  if (!cmp_read_object(ctx, &obj))+    return false;++  switch (obj.type) {+    case CMP_TYPE_BIN8:+    case CMP_TYPE_BIN16:+    case CMP_TYPE_BIN32:+      *size = obj.as.bin_size;+      return true;+    default:+      ctx->error = INVALID_TYPE_ERROR;+      return false;+  }+}++bool cmp_read_bin(cmp_ctx_t *ctx, void *data, uint32_t *size) {+  uint32_t bin_size = 0;++  if (!cmp_read_bin_size(ctx, &bin_size))+    return false;++  if (bin_size > *size) {+    ctx->error = BIN_DATA_LENGTH_TOO_LONG_ERROR;+    return false;+  }++  if (!ctx->read(ctx, data, bin_size)) {+    ctx->error = DATA_READING_ERROR;+    return false;+  }++  *size = bin_size;+  return true;+}++bool cmp_read_array(cmp_ctx_t *ctx, uint32_t *size) {+  cmp_object_t obj;++  if (!cmp_read_object(ctx, &obj))+    return false;++  switch (obj.type) {+    case CMP_TYPE_FIXARRAY:+    case CMP_TYPE_ARRAY16:+    case CMP_TYPE_ARRAY32:+      *size = obj.as.array_size;+      return true;+    default:+      ctx->error = INVALID_TYPE_ERROR;+      return false;+  }+}++bool cmp_read_map(cmp_ctx_t *ctx, uint32_t *size) {+  cmp_object_t obj;++  if (!cmp_read_object(ctx, &obj))+    return false;++  switch (obj.type) {+    case CMP_TYPE_FIXMAP:+    case CMP_TYPE_MAP16:+    case CMP_TYPE_MAP32:+      *size = obj.as.map_size;+      return true;+    default:+      ctx->error = INVALID_TYPE_ERROR;+      return false;+  }+}++bool cmp_read_fixext1_marker(cmp_ctx_t *ctx, int8_t *type) {+  cmp_object_t obj;++  if (!cmp_read_object(ctx, &obj))+    return false;++  if (obj.type != CMP_TYPE_FIXEXT1) {+    ctx->error = INVALID_TYPE_ERROR;+    return false;+  }++  *type = obj.as.ext.type;+  return true;+}++bool cmp_read_fixext1(cmp_ctx_t *ctx, int8_t *type, void *data) {+  if (!cmp_read_fixext1_marker(ctx, type))+    return false;++  if (ctx->read(ctx, data, 1))+    return true;++  ctx->error = DATA_READING_ERROR;+  return false;+}++bool cmp_read_fixext2_marker(cmp_ctx_t *ctx, int8_t *type) {+  cmp_object_t obj;++  if (!cmp_read_object(ctx, &obj))+    return false;++  if (obj.type != CMP_TYPE_FIXEXT2) {+    ctx->error = INVALID_TYPE_ERROR;+    return false;+  }++  *type = obj.as.ext.type;+  return true;+}++bool cmp_read_fixext2(cmp_ctx_t *ctx, int8_t *type, void *data) {+  if (!cmp_read_fixext2_marker(ctx, type))+    return false;++  if (ctx->read(ctx, data, 2))+    return true;++  ctx->error = DATA_READING_ERROR;+  return false;+}++bool cmp_read_fixext4_marker(cmp_ctx_t *ctx, int8_t *type) {+  cmp_object_t obj;++  if (!cmp_read_object(ctx, &obj))+    return false;++  if (obj.type != CMP_TYPE_FIXEXT4) {+    ctx->error = INVALID_TYPE_ERROR;+    return false;+  }++  *type = obj.as.ext.type;+  return true;+}++bool cmp_read_fixext4(cmp_ctx_t *ctx, int8_t *type, void *data) {+  if (!cmp_read_fixext4_marker(ctx, type))+    return false;++  if (ctx->read(ctx, data, 4))+    return true;++  ctx->error = DATA_READING_ERROR;+  return false;+}++bool cmp_read_fixext8_marker(cmp_ctx_t *ctx, int8_t *type) {+  cmp_object_t obj;++  if (!cmp_read_object(ctx, &obj))+    return false;++  if (obj.type != CMP_TYPE_FIXEXT8) {+    ctx->error = INVALID_TYPE_ERROR;+    return false;+  }++  *type = obj.as.ext.type;+  return true;+}++bool cmp_read_fixext8(cmp_ctx_t *ctx, int8_t *type, void *data) {+  if (!cmp_read_fixext8_marker(ctx, type))+    return false;++  if (ctx->read(ctx, data, 8))+    return true;++  ctx->error = DATA_READING_ERROR;+  return false;+}++bool cmp_read_fixext16_marker(cmp_ctx_t *ctx, int8_t *type) {+  cmp_object_t obj;++  if (!cmp_read_object(ctx, &obj))+    return false;++  if (obj.type != CMP_TYPE_FIXEXT16) {+    ctx->error = INVALID_TYPE_ERROR;+    return false;+  }++  *type = obj.as.ext.type;+  return true;+}++bool cmp_read_fixext16(cmp_ctx_t *ctx, int8_t *type, void *data) {+  if (!cmp_read_fixext16_marker(ctx, type))+    return false;++  if (ctx->read(ctx, data, 16))+    return true;++  ctx->error = DATA_READING_ERROR;+  return false;+}++bool cmp_read_ext8_marker(cmp_ctx_t *ctx, int8_t *type, uint8_t *size) {+  cmp_object_t obj;++  if (!cmp_read_object(ctx, &obj))+    return false;++  if (obj.type != CMP_TYPE_EXT8) {+    ctx->error = INVALID_TYPE_ERROR;+    return false;+  }++  *type = obj.as.ext.type;+  *size = (uint8_t)obj.as.ext.size;++  return true;+}++bool cmp_read_ext8(cmp_ctx_t *ctx, int8_t *type, uint8_t *size, void *data) {+  if (!cmp_read_ext8_marker(ctx, type, size))+    return false;++  if (ctx->read(ctx, data, *size))+    return true;++  ctx->error = DATA_READING_ERROR;+  return false;+}++bool cmp_read_ext16_marker(cmp_ctx_t *ctx, int8_t *type, uint16_t *size) {+  cmp_object_t obj;++  if (!cmp_read_object(ctx, &obj))+    return false;++  if (obj.type != CMP_TYPE_EXT16) {+    ctx->error = INVALID_TYPE_ERROR;+    return false;+  }++  *type = obj.as.ext.type;+  *size = (uint16_t)obj.as.ext.size;++  return true;+}++bool cmp_read_ext16(cmp_ctx_t *ctx, int8_t *type, uint16_t *size, void *data) {+  if (!cmp_read_ext16_marker(ctx, type, size))+    return false;++  if (ctx->read(ctx, data, *size))+    return true;++  ctx->error = DATA_READING_ERROR;+  return false;+}++bool cmp_read_ext32_marker(cmp_ctx_t *ctx, int8_t *type, uint32_t *size) {+  cmp_object_t obj;++  if (!cmp_read_object(ctx, &obj))+    return false;++  if (obj.type != CMP_TYPE_EXT32) {+    ctx->error = INVALID_TYPE_ERROR;+    return false;+  }++  *type = obj.as.ext.type;+  *size = obj.as.ext.size;++  return true;+}++bool cmp_read_ext32(cmp_ctx_t *ctx, int8_t *type, uint32_t *size, void *data) {+  if (!cmp_read_ext32_marker(ctx, type, size))+    return false;++  if (ctx->read(ctx, data, *size))+    return true;++  ctx->error = DATA_READING_ERROR;+  return false;+}++bool cmp_read_ext_marker(cmp_ctx_t *ctx, int8_t *type, uint32_t *size) {+  cmp_object_t obj;++  if (!cmp_read_object(ctx, &obj))+    return false;++  switch (obj.type) {+    case CMP_TYPE_FIXEXT1:+    case CMP_TYPE_FIXEXT2:+    case CMP_TYPE_FIXEXT4:+    case CMP_TYPE_FIXEXT8:+    case CMP_TYPE_FIXEXT16:+    case CMP_TYPE_EXT8:+    case CMP_TYPE_EXT16:+    case CMP_TYPE_EXT32:+      *type = obj.as.ext.type;+      *size = obj.as.ext.size;+      return true;+    default:+      ctx->error = INVALID_TYPE_ERROR;+      return false;+  }+}++bool cmp_read_ext(cmp_ctx_t *ctx, int8_t *type, uint32_t *size, void *data) {+  if (!cmp_read_ext_marker(ctx, type, size))+    return false;++  if (ctx->read(ctx, data, *size))+    return true;++  ctx->error = DATA_READING_ERROR;+  return false;+}++bool cmp_read_object(cmp_ctx_t *ctx, cmp_object_t *obj) {+  uint8_t type_marker = 0;++  if (!read_type_marker(ctx, &type_marker))+    return false;++  if (!type_marker_to_cmp_type(type_marker, &obj->type)) {+    ctx->error = INVALID_TYPE_ERROR;+    return false;+  }++  return read_obj_data(ctx, type_marker, obj);+}++bool cmp_skip_object(cmp_ctx_t *ctx, cmp_object_t *obj) {+  uint8_t type_marker = 0;+  uint8_t cmp_type;+  uint32_t size = 0;++  if (!read_type_marker(ctx, &type_marker)) {+    return false;+  }++  if (!type_marker_to_cmp_type(type_marker, &cmp_type)) {+    ctx->error = INVALID_TYPE_ERROR;+    return false;+  }++  switch (cmp_type) {+    case CMP_TYPE_FIXARRAY:+    case CMP_TYPE_ARRAY16:+    case CMP_TYPE_ARRAY32:+    case CMP_TYPE_FIXMAP:+    case CMP_TYPE_MAP16:+    case CMP_TYPE_MAP32:+      obj->type = cmp_type;++      if (!read_obj_data(ctx, type_marker, obj)) {+        return false;+      }++      ctx->error = SKIP_DEPTH_LIMIT_EXCEEDED_ERROR;++      return false;+    default:+      if (!read_type_size(ctx, type_marker, cmp_type, &size)) {+        return false;+      }++      if (size) {+        switch (cmp_type) {+          case CMP_TYPE_FIXEXT1:+          case CMP_TYPE_FIXEXT2:+          case CMP_TYPE_FIXEXT4:+          case CMP_TYPE_FIXEXT8:+          case CMP_TYPE_FIXEXT16:+          case CMP_TYPE_EXT8:+          case CMP_TYPE_EXT16:+          case CMP_TYPE_EXT32:+            size++;+            break;+          default:+            break;+        }++        skip_bytes(ctx, size);+      }+  }++  return true;+}++bool cmp_skip_object_flat(cmp_ctx_t *ctx, cmp_object_t *obj) {+  size_t element_count = 1;+  bool in_container = false;++  while (element_count) {+    uint8_t type_marker = 0;+    uint8_t cmp_type;+    uint32_t size = 0;++    if (!read_type_marker(ctx, &type_marker)) {+      return false;+    }++    if (!type_marker_to_cmp_type(type_marker, &cmp_type)) {+      ctx->error = INVALID_TYPE_ERROR;+      return false;+    }++    switch (cmp_type) {+      case CMP_TYPE_FIXARRAY:+      case CMP_TYPE_ARRAY16:+      case CMP_TYPE_ARRAY32:+      case CMP_TYPE_FIXMAP:+      case CMP_TYPE_MAP16:+      case CMP_TYPE_MAP32:+        if (in_container) {+          obj->type = cmp_type;++          if (!read_obj_data(ctx, type_marker, obj)) {+            return false;+          }++          ctx->error = SKIP_DEPTH_LIMIT_EXCEEDED_ERROR;+          return false;+        }++        in_container = true;++        break;+      default:+        if (!read_type_size(ctx, type_marker, cmp_type, &size)) {+          return false;+        }++        if (size) {+          switch (cmp_type) {+            case CMP_TYPE_FIXEXT1:+            case CMP_TYPE_FIXEXT2:+            case CMP_TYPE_FIXEXT4:+            case CMP_TYPE_FIXEXT8:+            case CMP_TYPE_FIXEXT16:+            case CMP_TYPE_EXT8:+            case CMP_TYPE_EXT16:+            case CMP_TYPE_EXT32:+              size++;+              break;+            default:+              break;+          }++          skip_bytes(ctx, size);+        }+    }++    element_count--;++    switch (cmp_type) {+      case CMP_TYPE_FIXARRAY:+      case CMP_TYPE_ARRAY16:+      case CMP_TYPE_ARRAY32:+        if (!read_type_size(ctx, type_marker, cmp_type, &size)) {+          return false;+        }+        element_count += size;+        break;+      case CMP_TYPE_FIXMAP:+      case CMP_TYPE_MAP16:+      case CMP_TYPE_MAP32:+        if (!read_type_size(ctx, type_marker, cmp_type, &size)) {+          return false;+        }+        element_count += ((size_t)size) * 2;+        break;+      default:+        break;+    }+  }++  return true;+}++bool cmp_skip_object_no_limit(cmp_ctx_t *ctx) {+  size_t element_count = 1;++  while (element_count) {+    uint8_t type_marker = 0;+    uint8_t cmp_type = 0;+    uint32_t size = 0;++    if (!read_type_marker(ctx, &type_marker)) {+      return false;+    }++    if (!type_marker_to_cmp_type(type_marker, &cmp_type)) {+      ctx->error = INVALID_TYPE_ERROR;+      return false;+    }++    switch (cmp_type) {+      case CMP_TYPE_FIXARRAY:+      case CMP_TYPE_ARRAY16:+      case CMP_TYPE_ARRAY32:+      case CMP_TYPE_FIXMAP:+      case CMP_TYPE_MAP16:+      case CMP_TYPE_MAP32:+        break;+      default:+        if (!read_type_size(ctx, type_marker, cmp_type, &size)) {+          return false;+        }++        if (size) {+          switch (cmp_type) {+            case CMP_TYPE_FIXEXT1:+            case CMP_TYPE_FIXEXT2:+            case CMP_TYPE_FIXEXT4:+            case CMP_TYPE_FIXEXT8:+            case CMP_TYPE_FIXEXT16:+            case CMP_TYPE_EXT8:+            case CMP_TYPE_EXT16:+            case CMP_TYPE_EXT32:+              size++;+              break;+            default:+              break;+          }++          skip_bytes(ctx, size);+        }+    }++    element_count--;++    switch (cmp_type) {+      case CMP_TYPE_FIXARRAY:+      case CMP_TYPE_ARRAY16:+      case CMP_TYPE_ARRAY32:+        if (!read_type_size(ctx, type_marker, cmp_type, &size)) {+          return false;+        }+        element_count += size;+        break;+      case CMP_TYPE_FIXMAP:+      case CMP_TYPE_MAP16:+      case CMP_TYPE_MAP32:+        if (!read_type_size(ctx, type_marker, cmp_type, &size)) {+          return false;+        }+        element_count += ((size_t)size) * 2;+        break;+      default:+        break;+    }+  }++  return true;+}++bool cmp_skip_object_limit(cmp_ctx_t *ctx, cmp_object_t *obj, uint32_t limit) {+  size_t element_count = 1;+  uint32_t depth = 0;++  while (element_count) {+    uint8_t type_marker = 0;+    uint8_t cmp_type;+    uint32_t size = 0;++    if (!read_type_marker(ctx, &type_marker)) {+      return false;+    }++    if (!type_marker_to_cmp_type(type_marker, &cmp_type)) {+      ctx->error = INVALID_TYPE_ERROR;+      return false;+    }++    switch (cmp_type) {+      case CMP_TYPE_FIXARRAY:+      case CMP_TYPE_ARRAY16:+      case CMP_TYPE_ARRAY32:+      case CMP_TYPE_FIXMAP:+      case CMP_TYPE_MAP16:+      case CMP_TYPE_MAP32:+        depth++;++        if (depth > limit) {+          obj->type = cmp_type;++          if (!read_obj_data(ctx, type_marker, obj)) {+            return false;+          }++          ctx->error = SKIP_DEPTH_LIMIT_EXCEEDED_ERROR;++          return false;+        }++        break;+      default:+        if (!read_type_size(ctx, type_marker, cmp_type, &size)) {+          return false;+        }++        if (size) {+          switch (cmp_type) {+            case CMP_TYPE_FIXEXT1:+            case CMP_TYPE_FIXEXT2:+            case CMP_TYPE_FIXEXT4:+            case CMP_TYPE_FIXEXT8:+            case CMP_TYPE_FIXEXT16:+            case CMP_TYPE_EXT8:+            case CMP_TYPE_EXT16:+            case CMP_TYPE_EXT32:+              size++;+              break;+            default:+              break;+          }++          skip_bytes(ctx, size);+        }+    }++    element_count--;++    switch (cmp_type) {+      case CMP_TYPE_FIXARRAY:+      case CMP_TYPE_ARRAY16:+      case CMP_TYPE_ARRAY32:+        if (!read_type_size(ctx, type_marker, cmp_type, &size)) {+          return false;+        }+        element_count += size;+        break;+      case CMP_TYPE_FIXMAP:+      case CMP_TYPE_MAP16:+      case CMP_TYPE_MAP32:+        if (!read_type_size(ctx, type_marker, cmp_type, &size)) {+          return false;+        }+        element_count += ((size_t)size) * 2;+        break;+      default:+        break;+    }+  }++  return true;+}++bool cmp_object_is_char(const cmp_object_t *obj) {+  switch (obj->type) {+    case CMP_TYPE_NEGATIVE_FIXNUM:+    case CMP_TYPE_SINT8:+      return true;+    default:+      return false;+  }+}++bool cmp_object_is_short(const cmp_object_t *obj) {+  switch (obj->type) {+    case CMP_TYPE_NEGATIVE_FIXNUM:+    case CMP_TYPE_SINT8:+    case CMP_TYPE_SINT16:+      return true;+    default:+      return false;+  }+}++bool cmp_object_is_int(const cmp_object_t *obj) {+  switch (obj->type) {+    case CMP_TYPE_NEGATIVE_FIXNUM:+    case CMP_TYPE_SINT8:+    case CMP_TYPE_SINT16:+    case CMP_TYPE_SINT32:+      return true;+    default:+      return false;+  }+}++bool cmp_object_is_long(const cmp_object_t *obj) {+  switch (obj->type) {+    case CMP_TYPE_NEGATIVE_FIXNUM:+    case CMP_TYPE_SINT8:+    case CMP_TYPE_SINT16:+    case CMP_TYPE_SINT32:+    case CMP_TYPE_SINT64:+      return true;+    default:+      return false;+  }+}++bool cmp_object_is_sinteger(const cmp_object_t *obj) {+  return cmp_object_is_long(obj);+}++bool cmp_object_is_uchar(const cmp_object_t *obj) {+  switch (obj->type) {+    case CMP_TYPE_POSITIVE_FIXNUM:+    case CMP_TYPE_UINT8:+      return true;+    default:+      return false;+  }+}++bool cmp_object_is_ushort(const cmp_object_t *obj) {+  switch (obj->type) {+    case CMP_TYPE_POSITIVE_FIXNUM:+    case CMP_TYPE_UINT8:+      return true;+    case CMP_TYPE_UINT16:+      return true;+    default:+      return false;+  }+}++bool cmp_object_is_uint(const cmp_object_t *obj) {+  switch (obj->type) {+    case CMP_TYPE_POSITIVE_FIXNUM:+    case CMP_TYPE_UINT8:+    case CMP_TYPE_UINT16:+    case CMP_TYPE_UINT32:+      return true;+    default:+      return false;+  }+}++bool cmp_object_is_ulong(const cmp_object_t *obj) {+  switch (obj->type) {+    case CMP_TYPE_POSITIVE_FIXNUM:+    case CMP_TYPE_UINT8:+    case CMP_TYPE_UINT16:+    case CMP_TYPE_UINT32:+    case CMP_TYPE_UINT64:+      return true;+    default:+      return false;+  }+}++bool cmp_object_is_uinteger(const cmp_object_t *obj) {+  return cmp_object_is_ulong(obj);+}++bool cmp_object_is_float(const cmp_object_t *obj) {+  if (obj->type == CMP_TYPE_FLOAT)+    return true;++  return false;+}++bool cmp_object_is_double(const cmp_object_t *obj) {+  if (obj->type == CMP_TYPE_DOUBLE)+    return true;++  return false;+}++bool cmp_object_is_nil(const cmp_object_t *obj) {+  if (obj->type == CMP_TYPE_NIL)+    return true;++  return false;+}++bool cmp_object_is_bool(const cmp_object_t *obj) {+  if (obj->type == CMP_TYPE_BOOLEAN)+    return true;++  return false;+}++bool cmp_object_is_str(const cmp_object_t *obj) {+  switch (obj->type) {+    case CMP_TYPE_FIXSTR:+    case CMP_TYPE_STR8:+    case CMP_TYPE_STR16:+    case CMP_TYPE_STR32:+      return true;+    default:+      return false;+  }+}++bool cmp_object_is_bin(const cmp_object_t *obj) {+  switch (obj->type) {+    case CMP_TYPE_BIN8:+    case CMP_TYPE_BIN16:+    case CMP_TYPE_BIN32:+      return true;+    default:+      return false;+  }+}++bool cmp_object_is_array(const cmp_object_t *obj) {+  switch (obj->type) {+    case CMP_TYPE_FIXARRAY:+    case CMP_TYPE_ARRAY16:+    case CMP_TYPE_ARRAY32:+      return true;+    default:+      return false;+  }+}++bool cmp_object_is_map(const cmp_object_t *obj) {+  switch (obj->type) {+    case CMP_TYPE_FIXMAP:+    case CMP_TYPE_MAP16:+    case CMP_TYPE_MAP32:+      return true;+    default:+      return false;+  }+}++bool cmp_object_is_ext(const cmp_object_t *obj) {+  switch (obj->type) {+    case CMP_TYPE_FIXEXT1:+    case CMP_TYPE_FIXEXT2:+    case CMP_TYPE_FIXEXT4:+    case CMP_TYPE_FIXEXT8:+    case CMP_TYPE_FIXEXT16:+    case CMP_TYPE_EXT8:+    case CMP_TYPE_EXT16:+    case CMP_TYPE_EXT32:+      return true;+    default:+      return false;+  }+}++bool cmp_object_as_char(const cmp_object_t *obj, int8_t *c) {+  switch (obj->type) {+    case CMP_TYPE_POSITIVE_FIXNUM:+    case CMP_TYPE_NEGATIVE_FIXNUM:+    case CMP_TYPE_SINT8:+      *c = obj->as.s8;+      return true;+    case CMP_TYPE_UINT8:+      if (obj->as.u8 <= 127) {+        *c = obj->as.s8;+        return true;+      }+      else {+        return false;+      }+    default:+        return false;+  }+}++bool cmp_object_as_short(const cmp_object_t *obj, int16_t *s) {+  switch (obj->type) {+    case CMP_TYPE_POSITIVE_FIXNUM:+    case CMP_TYPE_NEGATIVE_FIXNUM:+    case CMP_TYPE_SINT8:+      *s = obj->as.s8;+      return true;+    case CMP_TYPE_UINT8:+      *s = obj->as.u8;+      return true;+    case CMP_TYPE_SINT16:+      *s = obj->as.s16;+      return true;+    case CMP_TYPE_UINT16:+      if (obj->as.u16 <= 32767) {+        *s = (int16_t)obj->as.u16;+        return true;+      }+      else {+        return false;+      }+    default:+        return false;+  }+}++bool cmp_object_as_int(const cmp_object_t *obj, int32_t *i) {+  switch (obj->type) {+    case CMP_TYPE_POSITIVE_FIXNUM:+    case CMP_TYPE_NEGATIVE_FIXNUM:+    case CMP_TYPE_SINT8:+      *i = obj->as.s8;+      return true;+    case CMP_TYPE_UINT8:+      *i = obj->as.u8;+      return true;+    case CMP_TYPE_SINT16:+      *i = obj->as.s16;+      return true;+    case CMP_TYPE_UINT16:+      *i = obj->as.u16;+      return true;+    case CMP_TYPE_SINT32:+      *i = obj->as.s32;+      return true;+    case CMP_TYPE_UINT32:+      if (obj->as.u32 <= 2147483647) {+        *i = (int32_t)obj->as.u32;+        return true;+      }+      else {+        return false;+      }+    default:+        return false;+  }+}++bool cmp_object_as_long(const cmp_object_t *obj, int64_t *d) {+  switch (obj->type) {+    case CMP_TYPE_POSITIVE_FIXNUM:+    case CMP_TYPE_NEGATIVE_FIXNUM:+    case CMP_TYPE_SINT8:+      *d = obj->as.s8;+      return true;+    case CMP_TYPE_UINT8:+      *d = obj->as.u8;+      return true;+    case CMP_TYPE_SINT16:+      *d = obj->as.s16;+      return true;+    case CMP_TYPE_UINT16:+      *d = obj->as.u16;+      return true;+    case CMP_TYPE_SINT32:+      *d = obj->as.s32;+      return true;+    case CMP_TYPE_UINT32:+      *d = obj->as.u32;+      return true;+    case CMP_TYPE_SINT64:+      *d = obj->as.s64;+      return true;+    case CMP_TYPE_UINT64:+      if (obj->as.u64 <= 9223372036854775807) {+        *d = (int64_t)obj->as.u64;+        return true;+      }+      else {+        return false;+      }+    default:+        return false;+  }+}++bool cmp_object_as_sinteger(const cmp_object_t *obj, int64_t *d) {+  return cmp_object_as_long(obj, d);+}++bool cmp_object_as_uchar(const cmp_object_t *obj, uint8_t *c) {+  switch (obj->type) {+    case CMP_TYPE_POSITIVE_FIXNUM:+    case CMP_TYPE_UINT8:+      *c = obj->as.u8;+      return true;+    default:+        return false;+  }+}++bool cmp_object_as_ushort(const cmp_object_t *obj, uint16_t *s) {+  switch (obj->type) {+    case CMP_TYPE_POSITIVE_FIXNUM:+    case CMP_TYPE_UINT8:+      *s = obj->as.u8;+      return true;+    case CMP_TYPE_UINT16:+      *s = obj->as.u16;+      return true;+    default:+        return false;+  }+}++bool cmp_object_as_uint(const cmp_object_t *obj, uint32_t *i) {+  switch (obj->type) {+    case CMP_TYPE_POSITIVE_FIXNUM:+    case CMP_TYPE_UINT8:+      *i = obj->as.u8;+      return true;+    case CMP_TYPE_UINT16:+      *i = obj->as.u16;+      return true;+    case CMP_TYPE_UINT32:+      *i = obj->as.u32;+      return true;+    default:+        return false;+  }+}++bool cmp_object_as_ulong(const cmp_object_t *obj, uint64_t *u) {+  switch (obj->type) {+    case CMP_TYPE_POSITIVE_FIXNUM:+    case CMP_TYPE_UINT8:+      *u = obj->as.u8;+      return true;+    case CMP_TYPE_UINT16:+      *u = obj->as.u16;+      return true;+    case CMP_TYPE_UINT32:+      *u = obj->as.u32;+      return true;+    case CMP_TYPE_UINT64:+      *u = obj->as.u64;+      return true;+    default:+        return false;+  }+}++bool cmp_object_as_uinteger(const cmp_object_t *obj, uint64_t *u) {+  return cmp_object_as_ulong(obj, u);+}++#ifndef CMP_NO_FLOAT+bool cmp_object_as_float(const cmp_object_t *obj, float *f) {+  if (obj->type == CMP_TYPE_FLOAT) {+    *f = obj->as.flt;+    return true;+  }++  return false;+}++bool cmp_object_as_double(const cmp_object_t *obj, double *d) {+  if (obj->type == CMP_TYPE_DOUBLE) {+    *d = obj->as.dbl;+    return true;+  }++  return false;+}+#endif /* CMP_NO_FLOAT */++bool cmp_object_as_bool(const cmp_object_t *obj, bool *b) {+  if (obj->type == CMP_TYPE_BOOLEAN) {+    if (obj->as.boolean)+      *b = true;+    else+      *b = false;++    return true;+  }++  return false;+}++bool cmp_object_as_str(const cmp_object_t *obj, uint32_t *size) {+  switch (obj->type) {+    case CMP_TYPE_FIXSTR:+    case CMP_TYPE_STR8:+    case CMP_TYPE_STR16:+    case CMP_TYPE_STR32:+      *size = obj->as.str_size;+      return true;+    default:+        return false;+  }+}++bool cmp_object_as_bin(const cmp_object_t *obj, uint32_t *size) {+  switch (obj->type) {+    case CMP_TYPE_BIN8:+    case CMP_TYPE_BIN16:+    case CMP_TYPE_BIN32:+      *size = obj->as.bin_size;+      return true;+    default:+        return false;+  }+}++bool cmp_object_as_array(const cmp_object_t *obj, uint32_t *size) {+  switch (obj->type) {+    case CMP_TYPE_FIXARRAY:+    case CMP_TYPE_ARRAY16:+    case CMP_TYPE_ARRAY32:+      *size = obj->as.array_size;+      return true;+    default:+        return false;+  }+}++bool cmp_object_as_map(const cmp_object_t *obj, uint32_t *size) {+  switch (obj->type) {+    case CMP_TYPE_FIXMAP:+    case CMP_TYPE_MAP16:+    case CMP_TYPE_MAP32:+      *size = obj->as.map_size;+      return true;+    default:+        return false;+  }+}++bool cmp_object_as_ext(const cmp_object_t *obj, int8_t *type, uint32_t *size) {+  switch (obj->type) {+    case CMP_TYPE_FIXEXT1:+    case CMP_TYPE_FIXEXT2:+    case CMP_TYPE_FIXEXT4:+    case CMP_TYPE_FIXEXT8:+    case CMP_TYPE_FIXEXT16:+    case CMP_TYPE_EXT8:+    case CMP_TYPE_EXT16:+    case CMP_TYPE_EXT32:+      *type = obj->as.ext.type;+      *size = obj->as.ext.size;+      return true;+    default:+        return false;+  }+}++bool cmp_object_to_str(cmp_ctx_t *ctx, const cmp_object_t *obj, char *data,+                                                          uint32_t buf_size) {+  uint32_t str_size = 0;++  switch (obj->type) {+    case CMP_TYPE_FIXSTR:+    case CMP_TYPE_STR8:+    case CMP_TYPE_STR16:+    case CMP_TYPE_STR32:+      str_size = obj->as.str_size;+      if (str_size >= buf_size) {+        ctx->error = STR_DATA_LENGTH_TOO_LONG_ERROR;+        return false;+      }++      if (!ctx->read(ctx, data, str_size)) {+        ctx->error = DATA_READING_ERROR;+        return false;+      }++      data[str_size] = 0;+      return true;+    default:+      return false;+  }+}++bool cmp_object_to_bin(cmp_ctx_t *ctx, const cmp_object_t *obj, void *data,+                                                          uint32_t buf_size) {+  uint32_t bin_size = 0;++  switch (obj->type) {+    case CMP_TYPE_BIN8:+    case CMP_TYPE_BIN16:+    case CMP_TYPE_BIN32:+      bin_size = obj->as.bin_size;+      if (bin_size > buf_size) {+        ctx->error = BIN_DATA_LENGTH_TOO_LONG_ERROR;+        return false;+      }++      if (!ctx->read(ctx, data, bin_size)) {+        ctx->error = DATA_READING_ERROR;+        return false;+      }+      return true;+    default:+      return false;+  }+}++/* vi: set et ts=2 sw=2: */+
+ cbits/cmp.h view
@@ -0,0 +1,572 @@+/*+The MIT License (MIT)++Copyright (c) 2020 Charles Gunyon++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.+*/++#ifndef CMP_H_INCLUDED+#define CMP_H_INCLUDED++#include <stdbool.h>+#include <stddef.h>+#include <stdint.h>++struct cmp_ctx_s;++typedef bool   (*cmp_reader)(struct cmp_ctx_s *ctx, void *data, size_t limit);+typedef bool   (*cmp_skipper)(struct cmp_ctx_s *ctx, size_t count);+typedef size_t (*cmp_writer)(struct cmp_ctx_s *ctx, const void *data,+                                                    size_t count);++enum {+  CMP_TYPE_POSITIVE_FIXNUM, /*  0 */+  CMP_TYPE_FIXMAP,          /*  1 */+  CMP_TYPE_FIXARRAY,        /*  2 */+  CMP_TYPE_FIXSTR,          /*  3 */+  CMP_TYPE_NIL,             /*  4 */+  CMP_TYPE_BOOLEAN,         /*  5 */+  CMP_TYPE_BIN8,            /*  6 */+  CMP_TYPE_BIN16,           /*  7 */+  CMP_TYPE_BIN32,           /*  8 */+  CMP_TYPE_EXT8,            /*  9 */+  CMP_TYPE_EXT16,           /* 10 */+  CMP_TYPE_EXT32,           /* 11 */+  CMP_TYPE_FLOAT,           /* 12 */+  CMP_TYPE_DOUBLE,          /* 13 */+  CMP_TYPE_UINT8,           /* 14 */+  CMP_TYPE_UINT16,          /* 15 */+  CMP_TYPE_UINT32,          /* 16 */+  CMP_TYPE_UINT64,          /* 17 */+  CMP_TYPE_SINT8,           /* 18 */+  CMP_TYPE_SINT16,          /* 19 */+  CMP_TYPE_SINT32,          /* 20 */+  CMP_TYPE_SINT64,          /* 21 */+  CMP_TYPE_FIXEXT1,         /* 22 */+  CMP_TYPE_FIXEXT2,         /* 23 */+  CMP_TYPE_FIXEXT4,         /* 24 */+  CMP_TYPE_FIXEXT8,         /* 25 */+  CMP_TYPE_FIXEXT16,        /* 26 */+  CMP_TYPE_STR8,            /* 27 */+  CMP_TYPE_STR16,           /* 28 */+  CMP_TYPE_STR32,           /* 29 */+  CMP_TYPE_ARRAY16,         /* 30 */+  CMP_TYPE_ARRAY32,         /* 31 */+  CMP_TYPE_MAP16,           /* 32 */+  CMP_TYPE_MAP32,           /* 33 */+  CMP_TYPE_NEGATIVE_FIXNUM  /* 34 */+};++typedef struct cmp_ext_s {+  int8_t type;+  uint32_t size;+} cmp_ext_t;++union cmp_object_data_u {+  bool      boolean;+  uint8_t   u8;+  uint16_t  u16;+  uint32_t  u32;+  uint64_t  u64;+  int8_t    s8;+  int16_t   s16;+  int32_t   s32;+  int64_t   s64;+#ifndef CMP_NO_FLOAT+  float     flt;+  double    dbl;+#endif /* CMP_NO_FLOAT */+  uint32_t  array_size;+  uint32_t  map_size;+  uint32_t  str_size;+  uint32_t  bin_size;+  cmp_ext_t ext;+};++typedef struct cmp_ctx_s {+  uint8_t      error;+  void        *buf;+  cmp_reader   read;+  cmp_skipper  skip;+  cmp_writer   write;+} cmp_ctx_t;++typedef struct cmp_object_s {+  uint8_t type;+  union cmp_object_data_u as;+} cmp_object_t;++#ifdef __cplusplus+extern "C" {+#endif++/*+ * ============================================================================+ * === Main API+ * ============================================================================+ */++/*+ * Initializes a CMP context+ *+ * If you don't intend to read, `read` may be NULL, but calling `*read*`+ * functions will crash; there is no check.+ *+ * `skip` may be NULL, in which case skipping functions will use `read`.+ *+ * If you don't intend to write, `write` may be NULL, but calling `*write*`+ * functions will crash; there is no check.+ */+void cmp_init(cmp_ctx_t *ctx, void *buf, cmp_reader read,+                                         cmp_skipper skip,+                                         cmp_writer write);++/* Returns CMP's version */+uint32_t cmp_version(void);++/* Returns the MessagePack version employed by CMP */+uint32_t cmp_mp_version(void);++/* Returns a string description of a CMP context's error */+const char* cmp_strerror(cmp_ctx_t *ctx);++/* Writes a signed integer to the backend */+bool cmp_write_integer(cmp_ctx_t *ctx, int64_t d);++/* Writes an unsigned integer to the backend */+bool cmp_write_uinteger(cmp_ctx_t *ctx, uint64_t u);++/*+ * Writes a floating-point value (either single or double-precision) to the+ * backend+ */+#ifndef CMP_NO_FLOAT+bool cmp_write_decimal(cmp_ctx_t *ctx, double d);+#endif /* CMP_NO_FLOAT */++/* Writes NULL to the backend */+bool cmp_write_nil(cmp_ctx_t *ctx);++/* Writes true to the backend */+bool cmp_write_true(cmp_ctx_t *ctx);++/* Writes false to the backend */+bool cmp_write_false(cmp_ctx_t *ctx);++/* Writes a boolean value to the backend */+bool cmp_write_bool(cmp_ctx_t *ctx, bool b);++/*+ * Writes an unsigned char's value to the backend as a boolean.  This is useful+ * if you are using a different boolean type in your application.+ */+bool cmp_write_u8_as_bool(cmp_ctx_t *ctx, uint8_t b);++/*+ * Writes a string to the backend; according to the MessagePack spec, this must+ * be encoded using UTF-8, but CMP leaves that job up to the programmer.+ */+bool cmp_write_str(cmp_ctx_t *ctx, const char *data, uint32_t size);++/*+ * Writes a string to the backend.  This avoids using the STR8 marker, which+ * is unsupported by MessagePack v4, the version implemented by many other+ * MessagePack libraries.  No encoding is assumed in this case, not that it+ * matters.+ */+bool cmp_write_str_v4(cmp_ctx_t *ctx, const char *data, uint32_t size);++/*+ * Writes the string marker to the backend.  This is useful if you are writing+ * data in chunks instead of a single shot.+ */+bool cmp_write_str_marker(cmp_ctx_t *ctx, uint32_t size);++/*+ * Writes the string marker to the backend.  This is useful if you are writing+ * data in chunks instead of a single shot.  This avoids using the STR8+ * marker, which is unsupported by MessagePack v4, the version implemented by+ * many other MessagePack libraries.  No encoding is assumed in this case, not+ * that it matters.+ */+bool cmp_write_str_marker_v4(cmp_ctx_t *ctx, uint32_t size);++/* Writes binary data to the backend */+bool cmp_write_bin(cmp_ctx_t *ctx, const void *data, uint32_t size);++/*+ * Writes the binary data marker to the backend.  This is useful if you are+ * writing data in chunks instead of a single shot.+ */+bool cmp_write_bin_marker(cmp_ctx_t *ctx, uint32_t size);++/* Writes an array to the backend. */+bool cmp_write_array(cmp_ctx_t *ctx, uint32_t size);++/* Writes a map to the backend. */+bool cmp_write_map(cmp_ctx_t *ctx, uint32_t size);++/* Writes an extended type to the backend */+bool cmp_write_ext(cmp_ctx_t *ctx, int8_t type, uint32_t size,+                                   const void *data);++/*+ * Writes the extended type marker to the backend.  This is useful if you want+ * to write the type's data in chunks instead of a single shot.+ */+bool cmp_write_ext_marker(cmp_ctx_t *ctx, int8_t type, uint32_t size);++/* Writes an object to the backend */+bool cmp_write_object(cmp_ctx_t *ctx, const cmp_object_t *obj);++/*+ * Writes an object to the backend. This avoids using the STR8 marker, which+ * is unsupported by MessagePack v4, the version implemented by many other+ * MessagePack libraries.+ */+bool cmp_write_object_v4(cmp_ctx_t *ctx, const cmp_object_t *obj);++/* Reads a signed integer that fits inside a signed char */+bool cmp_read_char(cmp_ctx_t *ctx, int8_t *c);++/* Reads a signed integer that fits inside a signed short */+bool cmp_read_short(cmp_ctx_t *ctx, int16_t *s);++/* Reads a signed integer that fits inside a signed int */+bool cmp_read_int(cmp_ctx_t *ctx, int32_t *i);++/* Reads a signed integer that fits inside a signed long */+bool cmp_read_long(cmp_ctx_t *ctx, int64_t *d);++/* Reads a signed integer */+bool cmp_read_integer(cmp_ctx_t *ctx, int64_t *d);++/* Reads an unsigned integer that fits inside an unsigned char */+bool cmp_read_uchar(cmp_ctx_t *ctx, uint8_t *c);++/* Reads an unsigned integer that fits inside an unsigned short */+bool cmp_read_ushort(cmp_ctx_t *ctx, uint16_t *s);++/* Reads an unsigned integer that fits inside an unsigned int */+bool cmp_read_uint(cmp_ctx_t *ctx, uint32_t *i);++/* Reads an unsigned integer that fits inside an unsigned long */+bool cmp_read_ulong(cmp_ctx_t *ctx, uint64_t *u);++/* Reads an unsigned integer */+bool cmp_read_uinteger(cmp_ctx_t *ctx, uint64_t *u);++/*+ * Reads a floating point value (either single or double-precision) from the+ * backend+ */+#ifndef CMP_NO_FLOAT+bool cmp_read_decimal(cmp_ctx_t *ctx, double *d);+#endif /* CMP_NO_FLOAT */++/* "Reads" (more like "skips") a NULL value from the backend */+bool cmp_read_nil(cmp_ctx_t *ctx);++/* Reads a boolean from the backend */+bool cmp_read_bool(cmp_ctx_t *ctx, bool *b);++/*+ * Reads a boolean as an unsigned char from the backend; this is useful if your+ * application uses a different boolean type.+ */+bool cmp_read_bool_as_u8(cmp_ctx_t *ctx, uint8_t *b);++/* Reads a string's size from the backend */+bool cmp_read_str_size(cmp_ctx_t *ctx, uint32_t *size);++/*+ * Reads a string from the backend; according to the spec, the string's data+ * ought to be encoded using UTF-8, but CMP leaves that job up to the programmer.+ */+bool cmp_read_str(cmp_ctx_t *ctx, char *data, uint32_t *size);++/* Reads the size of packed binary data from the backend */+bool cmp_read_bin_size(cmp_ctx_t *ctx, uint32_t *size);++/* Reads packed binary data from the backend */+bool cmp_read_bin(cmp_ctx_t *ctx, void *data, uint32_t *size);++/* Reads an array from the backend */+bool cmp_read_array(cmp_ctx_t *ctx, uint32_t *size);++/* Reads a map from the backend */+bool cmp_read_map(cmp_ctx_t *ctx, uint32_t *size);++/* Reads the extended type's marker from the backend */+bool cmp_read_ext_marker(cmp_ctx_t *ctx, int8_t *type, uint32_t *size);++/* Reads an extended type from the backend */+bool cmp_read_ext(cmp_ctx_t *ctx, int8_t *type, uint32_t *size, void *data);++/* Reads an object from the backend */+bool cmp_read_object(cmp_ctx_t *ctx, cmp_object_t *obj);++/*+ * Skips the next object from the backend.  If that object is an array or map,+ * this function will:+ *   - If `obj` is not `NULL`, fill in `obj` with that object+ *   - Set `ctx->error` to `SKIP_DEPTH_LIMIT_EXCEEDED_ERROR`+ *   - Return `false`+ * Otherwise:+ *   - (Don't touch `obj`)+ *   - Return `true`+ */+bool cmp_skip_object(cmp_ctx_t *ctx, cmp_object_t *obj);++/*+ * This is similar to `cmp_skip_object`, except it tolerates flat arrays and+ * maps.  If when skipping such an array or map this function encounters+ * another array/map, it will:+ *   - If `obj` is not `NULL`, fill in `obj` with that (nested) object+ *   - Set `ctx->error` to `SKIP_DEPTH_LIMIT_EXCEEDED_ERROR`+ *   - Return `false`+ * Otherwise:+ *   - (Don't touch `obj`)+ *   - Return `true`+ *+ * WARNING: This can cause your application to spend an unbounded amount of+ *          time reading nested data structures.  Unless you completely trust+ *          the data source, you should use `cmp_skip_object`.+ */+bool cmp_skip_object_flat(cmp_ctx_t *ctx, cmp_object_t *obj);++/*+ * This is similar to `cmp_skip_object`, except it will continually skip+ * nested data structures.+ *+ * WARNING: This can cause your application to spend an unbounded amount of+ *          time reading nested data structures.  Unless you completely trust+ *          the data source, you should use `cmp_skip_object`.+ */+bool cmp_skip_object_no_limit(cmp_ctx_t *ctx);++/*+ * WARNING: THIS FUNCTION IS DEPRECATED AND WILL BE REMOVED IN A FUTURE RELEASE+ *+ * There is no way to track depths across elements without allocation.  For+ * example, an array constructed as: `[ [] [] [] [] [] [] [] [] [] [] ]`+ * should be able to be skipped with `cmp_skip_object_limit(&cmp, &obj, 2)`.+ * However, because we cannot track depth across the elements, there's no way+ * to reset it after descending down into each element.+ *+ * This is similar to `cmp_skip_object`, except it tolerates up to `limit`+ * levels of nesting.  For example, in order to skip an array that contains a+ * map, call `cmp_skip_object_limit(ctx, &obj, 2)`.  Or in other words,+ * `cmp_skip_object(ctx, &obj)` acts similarly to `cmp_skip_object_limit(ctx,+ * &obj, 0)`+ *+ * Specifically, `limit` refers to depth, not breadth.  So in order to skip an+ * array that contains two arrays that each contain 3 strings, you would call+ * `cmp_skip_object_limit(ctx, &obj, 2).  In order to skip an array that+ * contains 4 arrays that each contain 1 string, you would still call+ * `cmp_skip_object_limit(ctx, &obj, 2).+ */+bool cmp_skip_object_limit(cmp_ctx_t *ctx, cmp_object_t *obj, uint32_t limit)+#ifdef __GNUC__+  __attribute__((deprecated))+#endif+;++#ifdef _MSC_VER+#pragma deprecated(cmp_skip_object_limit)+#endif++/*+ * ============================================================================+ * === Specific API+ * ============================================================================+ */++bool cmp_write_pfix(cmp_ctx_t *ctx, uint8_t c);+bool cmp_write_nfix(cmp_ctx_t *ctx, int8_t c);++bool cmp_write_sfix(cmp_ctx_t *ctx, int8_t c);+bool cmp_write_s8(cmp_ctx_t *ctx, int8_t c);+bool cmp_write_s16(cmp_ctx_t *ctx, int16_t s);+bool cmp_write_s32(cmp_ctx_t *ctx, int32_t i);+bool cmp_write_s64(cmp_ctx_t *ctx, int64_t l);++bool cmp_write_ufix(cmp_ctx_t *ctx, uint8_t c);+bool cmp_write_u8(cmp_ctx_t *ctx, uint8_t c);+bool cmp_write_u16(cmp_ctx_t *ctx, uint16_t s);+bool cmp_write_u32(cmp_ctx_t *ctx, uint32_t i);+bool cmp_write_u64(cmp_ctx_t *ctx, uint64_t l);++#ifndef CMP_NO_FLOAT+bool cmp_write_float(cmp_ctx_t *ctx, float f);+bool cmp_write_double(cmp_ctx_t *ctx, double d);+#endif /* CMP_NO_FLOAT */++bool cmp_write_fixstr_marker(cmp_ctx_t *ctx, uint8_t size);+bool cmp_write_fixstr(cmp_ctx_t *ctx, const char *data, uint8_t size);+bool cmp_write_str8_marker(cmp_ctx_t *ctx, uint8_t size);+bool cmp_write_str8(cmp_ctx_t *ctx, const char *data, uint8_t size);+bool cmp_write_str16_marker(cmp_ctx_t *ctx, uint16_t size);+bool cmp_write_str16(cmp_ctx_t *ctx, const char *data, uint16_t size);+bool cmp_write_str32_marker(cmp_ctx_t *ctx, uint32_t size);+bool cmp_write_str32(cmp_ctx_t *ctx, const char *data, uint32_t size);++bool cmp_write_bin8_marker(cmp_ctx_t *ctx, uint8_t size);+bool cmp_write_bin8(cmp_ctx_t *ctx, const void *data, uint8_t size);+bool cmp_write_bin16_marker(cmp_ctx_t *ctx, uint16_t size);+bool cmp_write_bin16(cmp_ctx_t *ctx, const void *data, uint16_t size);+bool cmp_write_bin32_marker(cmp_ctx_t *ctx, uint32_t size);+bool cmp_write_bin32(cmp_ctx_t *ctx, const void *data, uint32_t size);++bool cmp_write_fixarray(cmp_ctx_t *ctx, uint8_t size);+bool cmp_write_array16(cmp_ctx_t *ctx, uint16_t size);+bool cmp_write_array32(cmp_ctx_t *ctx, uint32_t size);++bool cmp_write_fixmap(cmp_ctx_t *ctx, uint8_t size);+bool cmp_write_map16(cmp_ctx_t *ctx, uint16_t size);+bool cmp_write_map32(cmp_ctx_t *ctx, uint32_t size);++bool cmp_write_fixext1_marker(cmp_ctx_t *ctx, int8_t type);+bool cmp_write_fixext1(cmp_ctx_t *ctx, int8_t type, const void *data);+bool cmp_write_fixext2_marker(cmp_ctx_t *ctx, int8_t type);+bool cmp_write_fixext2(cmp_ctx_t *ctx, int8_t type, const void *data);+bool cmp_write_fixext4_marker(cmp_ctx_t *ctx, int8_t type);+bool cmp_write_fixext4(cmp_ctx_t *ctx, int8_t type, const void *data);+bool cmp_write_fixext8_marker(cmp_ctx_t *ctx, int8_t type);+bool cmp_write_fixext8(cmp_ctx_t *ctx, int8_t type, const void *data);+bool cmp_write_fixext16_marker(cmp_ctx_t *ctx, int8_t type);+bool cmp_write_fixext16(cmp_ctx_t *ctx, int8_t type, const void *data);++bool cmp_write_ext8_marker(cmp_ctx_t *ctx, int8_t type, uint8_t size);+bool cmp_write_ext8(cmp_ctx_t *ctx, int8_t type, uint8_t size,+                                    const void *data);+bool cmp_write_ext16_marker(cmp_ctx_t *ctx, int8_t type, uint16_t size);+bool cmp_write_ext16(cmp_ctx_t *ctx, int8_t type, uint16_t size,+                                     const void *data);+bool cmp_write_ext32_marker(cmp_ctx_t *ctx, int8_t type, uint32_t size);+bool cmp_write_ext32(cmp_ctx_t *ctx, int8_t type, uint32_t size,+                                     const void *data);++bool cmp_read_pfix(cmp_ctx_t *ctx, uint8_t *c);+bool cmp_read_nfix(cmp_ctx_t *ctx, int8_t *c);++bool cmp_read_sfix(cmp_ctx_t *ctx, int8_t *c);+bool cmp_read_s8(cmp_ctx_t *ctx, int8_t *c);+bool cmp_read_s16(cmp_ctx_t *ctx, int16_t *s);+bool cmp_read_s32(cmp_ctx_t *ctx, int32_t *i);+bool cmp_read_s64(cmp_ctx_t *ctx, int64_t *l);++bool cmp_read_ufix(cmp_ctx_t *ctx, uint8_t *c);+bool cmp_read_u8(cmp_ctx_t *ctx, uint8_t *c);+bool cmp_read_u16(cmp_ctx_t *ctx, uint16_t *s);+bool cmp_read_u32(cmp_ctx_t *ctx, uint32_t *i);+bool cmp_read_u64(cmp_ctx_t *ctx, uint64_t *l);++#ifndef CMP_NO_FLOAT+bool cmp_read_float(cmp_ctx_t *ctx, float *f);+bool cmp_read_double(cmp_ctx_t *ctx, double *d);+#endif /* CMP_NO_FLOAT */++bool cmp_read_fixext1_marker(cmp_ctx_t *ctx, int8_t *type);+bool cmp_read_fixext1(cmp_ctx_t *ctx, int8_t *type, void *data);+bool cmp_read_fixext2_marker(cmp_ctx_t *ctx, int8_t *type);+bool cmp_read_fixext2(cmp_ctx_t *ctx, int8_t *type, void *data);+bool cmp_read_fixext4_marker(cmp_ctx_t *ctx, int8_t *type);+bool cmp_read_fixext4(cmp_ctx_t *ctx, int8_t *type, void *data);+bool cmp_read_fixext8_marker(cmp_ctx_t *ctx, int8_t *type);+bool cmp_read_fixext8(cmp_ctx_t *ctx, int8_t *type, void *data);+bool cmp_read_fixext16_marker(cmp_ctx_t *ctx, int8_t *type);+bool cmp_read_fixext16(cmp_ctx_t *ctx, int8_t *type, void *data);++bool cmp_read_ext8_marker(cmp_ctx_t *ctx, int8_t *type, uint8_t *size);+bool cmp_read_ext8(cmp_ctx_t *ctx, int8_t *type, uint8_t *size, void *data);+bool cmp_read_ext16_marker(cmp_ctx_t *ctx, int8_t *type, uint16_t *size);+bool cmp_read_ext16(cmp_ctx_t *ctx, int8_t *type, uint16_t *size, void *data);+bool cmp_read_ext32_marker(cmp_ctx_t *ctx, int8_t *type, uint32_t *size);+bool cmp_read_ext32(cmp_ctx_t *ctx, int8_t *type, uint32_t *size, void *data);++/*+ * ============================================================================+ * === Object API+ * ============================================================================+ */++bool cmp_object_is_char(const cmp_object_t *obj);+bool cmp_object_is_short(const cmp_object_t *obj);+bool cmp_object_is_int(const cmp_object_t *obj);+bool cmp_object_is_long(const cmp_object_t *obj);+bool cmp_object_is_sinteger(const cmp_object_t *obj);+bool cmp_object_is_uchar(const cmp_object_t *obj);+bool cmp_object_is_ushort(const cmp_object_t *obj);+bool cmp_object_is_uint(const cmp_object_t *obj);+bool cmp_object_is_ulong(const cmp_object_t *obj);+bool cmp_object_is_uinteger(const cmp_object_t *obj);+bool cmp_object_is_float(const cmp_object_t *obj);+bool cmp_object_is_double(const cmp_object_t *obj);+bool cmp_object_is_nil(const cmp_object_t *obj);+bool cmp_object_is_bool(const cmp_object_t *obj);+bool cmp_object_is_str(const cmp_object_t *obj);+bool cmp_object_is_bin(const cmp_object_t *obj);+bool cmp_object_is_array(const cmp_object_t *obj);+bool cmp_object_is_map(const cmp_object_t *obj);+bool cmp_object_is_ext(const cmp_object_t *obj);++bool cmp_object_as_char(const cmp_object_t *obj, int8_t *c);+bool cmp_object_as_short(const cmp_object_t *obj, int16_t *s);+bool cmp_object_as_int(const cmp_object_t *obj, int32_t *i);+bool cmp_object_as_long(const cmp_object_t *obj, int64_t *d);+bool cmp_object_as_sinteger(const cmp_object_t *obj, int64_t *d);+bool cmp_object_as_uchar(const cmp_object_t *obj, uint8_t *c);+bool cmp_object_as_ushort(const cmp_object_t *obj, uint16_t *s);+bool cmp_object_as_uint(const cmp_object_t *obj, uint32_t *i);+bool cmp_object_as_ulong(const cmp_object_t *obj, uint64_t *u);+bool cmp_object_as_uinteger(const cmp_object_t *obj, uint64_t *u);+bool cmp_object_as_float(const cmp_object_t *obj, float *f);+bool cmp_object_as_double(const cmp_object_t *obj, double *d);+bool cmp_object_as_bool(const cmp_object_t *obj, bool *b);+bool cmp_object_as_str(const cmp_object_t *obj, uint32_t *size);+bool cmp_object_as_bin(const cmp_object_t *obj, uint32_t *size);+bool cmp_object_as_array(const cmp_object_t *obj, uint32_t *size);+bool cmp_object_as_map(const cmp_object_t *obj, uint32_t *size);+bool cmp_object_as_ext(const cmp_object_t *obj, int8_t *type, uint32_t *size);++bool cmp_object_to_str(cmp_ctx_t *ctx, const cmp_object_t *obj, char *data, uint32_t buf_size);+bool cmp_object_to_bin(cmp_ctx_t *ctx, const cmp_object_t *obj, void *data, uint32_t buf_size);++#ifdef __cplusplus+} /* extern "C" */+#endif++/*+ * ============================================================================+ * === Backwards compatibility defines+ * ============================================================================+ */++#define cmp_write_int      cmp_write_integer+#define cmp_write_sint     cmp_write_integer+#define cmp_write_sinteger cmp_write_integer+#define cmp_write_uint     cmp_write_uinteger+#define cmp_read_sinteger  cmp_read_integer++#endif /* CMP_H_INCLUDED */++/* vi: set et ts=2 sw=2: */+
+ cbits/fontconfig-wrap.c view
@@ -0,0 +1,722 @@+#include "transcode.h"+#include <fontconfig/fontconfig.h>+#include <stdlib.h>+#include <fontconfig/fcfreetype.h>++int fcPatternEqualSubset(uint8_t *data, size_t length) {+    cmp_ctx_t in;+    if (!cmp_bytes_init(&in, data, length)) return -1;+    uint32_t size = 0;+    if (!cmp_read_array(&in, &size) || size != 3) {+        cmp_bytes_take(&in, NULL);+        return -1;+    }+    FcPattern *pa = decodePattern(&in);+    if (pa == NULL) {cmp_bytes_take(&in, NULL); return -1;}+    FcPattern *pb = decodePattern(&in);+    if (pb == NULL) {+        cmp_bytes_take(&in, NULL);+        FcPatternDestroy(pa);+        return -1;+    }+    FcObjectSet *os = decodeObjectSet(&in);+    cmp_bytes_take(&in, NULL);++    int ret = -1;+    if (os != NULL) ret = FcPatternEqualSubset(pa, pb, os) ? 1 : 0;++    FcPatternDestroy(pa);+    FcPatternDestroy(pb);+    FcObjectSetDestroy(os);+    return ret;+}++uint8_t *fcDefaultSubstitute(uint8_t *data, size_t in_length, size_t *length) {+    cmp_ctx_t in;+    if (!cmp_bytes_init(&in, data, in_length)) return NULL;+    FcPattern *pat = decodePattern(&in);+    cmp_bytes_take(&in, NULL);+    if (pat == NULL) return NULL;++    FcDefaultSubstitute(pat);++    cmp_ctx_t out;+    if (!cmp_bytes_alloc(&out, 1024)) {FcPatternDestroy(pat); return NULL;}+    if (!encodePattern(&out, pat)) {+        cmp_bytes_free(&out);+        FcPatternDestroy(pat);+        return NULL;+    }+    FcPatternDestroy(pat);+    return cmp_bytes_take(&out, length);+}++uint8_t *fcNameParse(char *name, size_t *length) {+    FcPattern *pat = FcNameParse(name);+    if (pat == NULL) return NULL;++    cmp_ctx_t out;+    if (!cmp_bytes_alloc(&out, 1024)) {FcPatternDestroy(pat); return NULL;}+    if (!encodePattern(&out, pat)) {+        FcPatternDestroy(pat); cmp_bytes_free(&out); return NULL;+    }+    FcPatternDestroy(pat);+    return cmp_bytes_take(&out, length);+}++char *fcNameUnparse(uint8_t *data, size_t length) {+    cmp_ctx_t in;+    if (!cmp_bytes_init(&in, data, length)) return NULL;+    FcPattern *pat = decodePattern(&in);+    cmp_bytes_take(&in, NULL); // Caller frees `data`!+    if (pat == NULL) return NULL;++    char *ret = FcNameUnparse(pat);+    FcPatternDestroy(pat);+    return ret;+}++char *fcNameFormat(uint8_t *data, size_t length, char *format) {+    cmp_ctx_t in;+    if (!cmp_bytes_init(&in, data, length)) return NULL;+    FcPattern *pat = decodePattern(&in);+    cmp_bytes_take(&in, NULL); // Caller frees `data`!+    if (pat == NULL) return NULL;++    char *ret = FcPatternFormat(pat, format);+    FcPatternDestroy(pat);+    return ret;+}++uint8_t *fcFontSetList(FcConfig *config, uint8_t *sets, size_t sets_length,+        uint8_t *pat, size_t pat_length, uint8_t *objects, size_t objs_length, size_t *length) {+    cmp_ctx_t in;+    uint8_t *ret = NULL;++    if (!cmp_bytes_init(&in, sets, sets_length)) return NULL;+    size_t nsets;+    FcFontSet **fontsets = decodeFontSets(&in, &nsets);+    cmp_bytes_take(&in, NULL);+    if (fontsets == NULL) return NULL;++    if (!cmp_bytes_init(&in, pat, pat_length)) goto fail_pat;+    FcPattern *pattern = decodePattern(&in);+    cmp_bytes_take(&in, NULL);+    if (pattern == NULL) goto fail_pat;++    if (!cmp_bytes_init(&in, objects, objs_length)) goto fail_objs;+    FcObjectSet *objs = decodeObjectSet(&in);+    cmp_bytes_take(&in, NULL);+    if (objs == NULL) goto fail_objs;++    FcFontSet *res = FcFontSetList(config, fontsets, nsets, pattern, objs);+    if (res == NULL) goto fail_list;++    cmp_ctx_t out;+    if (!cmp_bytes_alloc(&out, 1024)) goto fail;+    bool ok = encodeFontSet(&out, res);+    ret = cmp_bytes_take(&out, length);+    if (!ok && ret != NULL) { free(ret); ret = NULL;}++fail:+    FcFontSetDestroy(res);+fail_list:+    FcObjectSetDestroy(objs);+fail_objs:+    FcPatternDestroy(pattern);+fail_pat:+    for (size_t i = 0; i < nsets; i++) FcFontSetDestroy(fontsets[i]);+    free(fontsets);+    return ret;+}+++// FcResultMatch, FcResultNoMatch, FcResultTypeMismatch, FcResultNoId, FcResultOutOfMemory++uint8_t *fcFontSetMatch(FcConfig *config, uint8_t *sets, size_t sets_length,+        uint8_t *pat, size_t pat_length, size_t *length) {+    cmp_ctx_t in;+    uint8_t *ret = NULL;++    if (!cmp_bytes_init(&in, sets, sets_length)) return NULL;+    size_t nsets;+    FcFontSet **fontsets = decodeFontSets(&in, &nsets);+    cmp_bytes_take(&in, NULL);+    if (fontsets == NULL) return NULL;++    if (!cmp_bytes_init(&in, pat, pat_length)) goto fail;+    FcPattern *pattern = decodePattern(&in);+    cmp_bytes_take(&in, NULL);+    if (pattern == NULL) goto fail;++    // Necessary preprocessing! Fold it into this C call, safer & *might* save overhead.+    FcPattern *res = NULL;+    if (!FcConfigSubstitute(config, pattern, FcMatchPattern)) goto fail2;+    FcDefaultSubstitute(pattern);++    FcResult err;+    res = FcFontSetMatch(config, fontsets, nsets, pattern, &err);+    if (res == NULL) goto fail2;++    cmp_ctx_t out;+    bool ok;+    if (err == FcResultMatch) {+        if (!cmp_bytes_alloc(&out, 1024)) goto fail2;+        ok = encodePattern(&out, res);+        ret = cmp_bytes_take(&out, length);+        if (!ok && ret != NULL) { free(ret); ret = NULL; }+    } else {+        if (!cmp_bytes_alloc(&out, 32)) goto fail2;+        ok = encodeResult(&out, err);+        ret = cmp_bytes_take(&out, length);+        if (!ok && ret != NULL) { free(ret); ret = NULL; }+    }++fail2:+    if (res != NULL) FcPatternDestroy(res);+    FcPatternDestroy(pattern);+fail:+    for (size_t i = 0; i < nsets; i++) FcFontSetDestroy(fontsets[i]);+    free(fontsets);+    return ret;+}++uint8_t *fcFontSetSort(FcConfig *config, uint8_t *sets, size_t sets_length,+        uint8_t *pat, size_t pat_length, bool trim, size_t *length) {+    cmp_ctx_t in;+    uint8_t *ret = NULL;++    if (!cmp_bytes_init(&in, sets, sets_length)) return NULL;+    size_t nsets;+    FcFontSet **fontsets = decodeFontSets(&in, &nsets);+    cmp_bytes_take(&in, NULL);+    if (fontsets == NULL) return NULL;++    if (!cmp_bytes_init(&in, pat, pat_length)) goto fail;+    FcPattern *pattern = decodePattern(&in);+    cmp_bytes_take(&in, NULL);+    if (pattern == NULL) goto fail;++    // Necessary preprocessing! Fold into this C call, safer & *might* save overhead.+    if (!FcConfigSubstitute(config, pattern, FcMatchPattern)) goto fail2;+    FcDefaultSubstitute(pattern);++    FcResult err;+    FcCharSet *charset = NULL;+    FcFontSet *res = FcFontSetSort(config, fontsets, nsets, pattern, trim, &charset, &err);+    if (res == NULL) goto fail2;++    cmp_ctx_t out;+    bool ok = true;+    switch (err) {+    case FcResultMatch:+        if (!cmp_bytes_alloc(&out, 1024*res->nfont)) goto fail3;+        ok = ok || cmp_write_array(&out, 2);+        if (res == NULL) cmp_write_nil(&out);+        else {+            ok = ok || encodeRenderableFontSet(&out, res);+        }+        if (charset == NULL) cmp_write_nil(&out);+        else ok = ok || encodeCharSet(&out, charset);+        break;+    case FcResultNoMatch:+        if (!cmp_bytes_alloc(&out, 1024)) goto fail3;+        ok = ok || cmp_write_array(&out, 2);+        ok = ok || cmp_write_array(&out, 0);+        if (charset == NULL) cmp_write_nil(&out);+        else ok = ok || encodeCharSet(&out, charset);+        break;+    default:+        if (!cmp_bytes_alloc(&out, 32)) goto fail3;+        ok = ok || encodeResult(&out, err);+    }+    ret = cmp_bytes_take(&out, length);+    if (!ok && ret != NULL) { free(ret); ret = NULL; }++fail3:+    FcFontSetDestroy(res);+    if (charset != NULL) FcCharSetDestroy(charset);+fail2:+    FcPatternDestroy(pattern);+fail:+    for (size_t i = 0; i < nsets; i++) FcFontSetDestroy(fontsets[i]);+    free(fontsets);+    return ret;+}++unsigned int fcFreeTypeCharIndex(FT_Face *face, uint32_t ucs4) {+    return FcFreeTypeCharIndex(*face, ucs4);+}++uint8_t *fcFreeTypeCharSet(FT_Face *face, size_t *length) {+    FcCharSet *res = FcFreeTypeCharSet(*face, NULL);++    if (res == NULL) return NULL;+    cmp_ctx_t out;+    if (!cmp_bytes_alloc(&out, 1024)) {+        FcCharSetDestroy(res);+        return NULL;+    }+    if (!encodeCharSet(&out, res)) {+        FcCharSetDestroy(res);+        cmp_bytes_free(&out);+        return NULL;+    }+    FcCharSetDestroy(res);+    return cmp_bytes_take(&out, length);;+}++uint8_t *fcFreeTypeCharSetAndSpacing(FT_Face *face, size_t *length) {+    int spacing;+    FcCharSet *res = FcFreeTypeCharSetAndSpacing(*face, NULL, &spacing);+    if (res == NULL) return NULL;++    cmp_ctx_t out;+    if (!cmp_bytes_alloc(&out, 1024)) {+        FcCharSetDestroy(res);+        return NULL;+    }+    if (!cmp_write_array(&out, 2)) goto fail;+    switch (spacing) { // This branches ensures a consistant ABI for Haskell to bind against.+    case FC_MONO:+        if (!cmp_write_integer(&out, 0)) goto fail;+        break;+    case FC_DUAL:+        if (!cmp_write_integer(&out, 1)) goto fail;+        break;+    case FC_PROPORTIONAL:+        if (!cmp_write_integer(&out, 2)) goto fail;+        break;+    default:+        if (!cmp_write_integer(&out, 3)) goto fail;+        break;+    }+    if (!encodeCharSet(&out, res)) goto fail;+    FcCharSetDestroy(res);+    return cmp_bytes_take(&out, length);;++fail:+    FcCharSetDestroy(res);+    cmp_bytes_free(&out);+    return NULL;+}++uint8_t *fcFreeTypeQuery(char *file, int id, size_t *length) {+    int count;+    FcPattern *res = FcFreeTypeQuery(file, id, NULL, &count);+    if (res == NULL) return NULL;++    cmp_ctx_t out;+    if (!cmp_bytes_alloc(&out, 1024)) {+        FcPatternDestroy(res);+        return NULL;+    }+    if (!cmp_write_array(&out, 2)) goto fail;+    if (!cmp_write_integer(&out, count)) goto fail;+    if (!encodePattern(&out, res)) goto fail;+    FcPatternDestroy(res);+    return cmp_bytes_take(&out, length);;++fail:+    FcPatternDestroy(res);+    cmp_bytes_free(&out);+    return NULL;+}++uint8_t *fcFreeTypeQueryAll(char *file, size_t *length) {+    int count;+    FcFontSet *fontset = FcFontSetCreate();+    if (fontset == NULL) return NULL;+    unsigned int npatterns = FcFreeTypeQueryAll(file, -1, NULL, &count, fontset);++    cmp_ctx_t out;+    if (!cmp_bytes_alloc(&out, 1024)) {+        FcFontSetDestroy(fontset);+        return NULL;+    }+    if (!cmp_write_array(&out, 3)) goto fail;+    if (!cmp_write_integer(&out, npatterns)) goto fail;+    if (!cmp_write_integer(&out, count)) goto fail;+    if (!encodeFontSet(&out, fontset)) goto fail;+    uint8_t *ret = cmp_bytes_take(&out, length);+    FcFontSetDestroy(fontset);+    return ret;++fail:+    FcFontSetDestroy(fontset);+    cmp_bytes_free(&out);+    return NULL;+}++uint8_t *fcFreeTypeQueryFace(FT_Face *face, char *file, int id, size_t *length) {+    FcPattern *res = FcFreeTypeQueryFace(*face, file, id, NULL);+    if (res == NULL) return NULL;++    cmp_ctx_t out;+    if (!cmp_bytes_alloc(&out, 1024)) {+        FcPatternDestroy(res);+        return NULL;+    }+    if (!encodePattern(&out, res)) {+        FcPatternDestroy(res);+        cmp_bytes_free(&out);+    }+    uint8_t *ret = cmp_bytes_take(&out, length);+    FcPatternDestroy(res);+    return ret;+}++int fcLangSetCompare(uint8_t *langset, size_t length) {+    cmp_ctx_t in;+    if (!cmp_bytes_init(&in, langset, length)) return -1;+    uint32_t size = 0;+    if (!cmp_read_array(&in, &size) || size != 2) {cmp_bytes_take(&in, NULL); return -1;}+    FcLangSet *a = decodeLangSet(&in);+    if (a == NULL) {cmp_bytes_take(&in, NULL); return -1;}+    FcLangSet *b = decodeLangSet(&in);+    cmp_bytes_take(&in, NULL);+    if (b == NULL) return -1;++    FcLangResult ret = FcLangSetCompare(a, b);+    FcLangSetDestroy(a);+    FcLangSetDestroy(b);++    switch (ret) {+    case FcLangDifferentLang: return 0;+    case FcLangEqual: return 1;+    case FcLangDifferentTerritory: return 2;+    default: return -2;+    }+}++int fcLangSetHasLang(uint8_t *langset, size_t length, const char *lang) {+    cmp_ctx_t in;+    if (!cmp_bytes_init(&in, langset, length)) return -1;+    FcLangSet *ls = decodeLangSet(&in);+    cmp_bytes_take(&in, NULL); // Caller frees `langset`+    if (ls == NULL) return -1;++    FcLangResult ret = FcLangSetHasLang(ls, lang);+    FcLangSetDestroy(ls);+    switch (ret) {+    case FcLangDifferentLang:+        return 0;+    case FcLangEqual:+        return 1;+    case FcLangDifferentTerritory:+        return 2;+    default:+        return -2;+    }+}++uint8_t *fcGetDefaultLangs(size_t *length) {+    FcStrSet *res = FcGetDefaultLangs();+    if (res == NULL) return NULL;++    cmp_ctx_t out;+    if (!cmp_bytes_alloc(&out, 1024)) {+        FcStrSetDestroy(res);+        return NULL;+    }+    if (!encodeStrSet(&out, res)) {+        cmp_bytes_free(&out);+        FcStrSetDestroy(res);+        return NULL;+    }+    FcStrSetDestroy(res);+    return cmp_bytes_take(&out, length);+}++uint8_t *fcGetLangs(size_t *length) {+    FcStrSet *res = FcGetLangs();+    if (res == NULL) return NULL;++    cmp_ctx_t out;+    if (!cmp_bytes_alloc(&out, 1024)) {+        FcStrSetDestroy(res);+        return NULL;+    }+    if (!encodeStrSet(&out, res)) {+        cmp_bytes_free(&out);+        FcStrSetDestroy(res);+        return NULL;+    }+    FcStrSetDestroy(res);+    return cmp_bytes_take(&out, length);+}++char *fcLangNormalize(char *lang) {return FcLangNormalize(lang);}++uint8_t *fcLangGetCharSet(const char *lang, size_t *length) {+    const FcCharSet *res = FcLangGetCharSet(lang);+    if (res == NULL) return NULL;++    cmp_ctx_t out;+    if (!cmp_bytes_alloc(&out, 1024)) return NULL;+    if (!encodeCharSet(&out, res)) {+        cmp_bytes_free(&out);+        return NULL;+    }+    return cmp_bytes_take(&out, length);+}++uint8_t *fcConfigGetConfigDirs(FcConfig *conf, size_t *length) {+    FcStrList *res = FcConfigGetConfigDirs(conf);+    if (res == NULL) return NULL;++    cmp_ctx_t out;+    if (!cmp_bytes_alloc(&out, 1024)) {+        FcStrListDone(res);+        return NULL;+    }+    if (!encodeStrList(&out, res)) {+        cmp_bytes_free(&out);+        FcStrListDone(res);+        return NULL;+    }+    FcStrListDone(res);+    return cmp_bytes_take(&out, length);+}++uint8_t *fcConfigGetFontDirs(FcConfig *conf, size_t *length) {+    FcStrList *res = FcConfigGetFontDirs(conf);+    if (res == NULL) return NULL;++    cmp_ctx_t out;+    if (!cmp_bytes_alloc(&out, 1024)) {+        FcStrListDone(res);+        return NULL;+    }+    if (!encodeStrList(&out, res)) {+        cmp_bytes_free(&out);+        FcStrListDone(res);+        return NULL;+    }+    FcStrListDone(res);+    return cmp_bytes_take(&out, length);+}++uint8_t *fcConfigGetConfigFiles(FcConfig *conf, size_t *length) {+    FcStrList *res = FcConfigGetConfigFiles(conf);+    if (res == NULL) return NULL;++    cmp_ctx_t out;+    if (!cmp_bytes_alloc(&out, 1024)) {+        FcStrListDone(res);+        return NULL;+    }+    if (!encodeStrList(&out, res)) {+        cmp_bytes_free(&out);+        FcStrListDone(res);+        return NULL;+    }+    FcStrListDone(res);+    return cmp_bytes_take(&out, length);+}++uint8_t *fcConfigGetCacheDirs(FcConfig *conf, size_t *length) {+    FcStrList *res = FcConfigGetCacheDirs(conf);+    if (res == NULL) return NULL;++    cmp_ctx_t out;+    if (!cmp_bytes_alloc(&out, 1024)) {+        FcStrListDone(res);+        return NULL;+    }+    if (!encodeStrList(&out, res)) {+        cmp_bytes_free(&out);+        FcStrListDone(res);+        return NULL;+    }+    FcStrListDone(res);+    return cmp_bytes_take(&out, length);+}++uint8_t *fcConfigGetFonts(FcConfig *conf, bool system, size_t *length) {+    // NOTE: We shouldn't free results!+    FcFontSet *res = FcConfigGetFonts(conf, system ? FcSetSystem : FcSetApplication);+    if (res == NULL) return NULL;++    cmp_ctx_t out;+    if (!cmp_bytes_alloc(&out, 1024)) return NULL;+    if (!encodeFontSet(&out, res)) {+        cmp_bytes_free(&out);+        return NULL;+    }+    return cmp_bytes_take(&out, length);+}++uint8_t *fcConfigSubstituteWithPat(FcConfig *conf, uint8_t *data, size_t in_length, bool isFont, size_t *length) {+    cmp_ctx_t in;+    if (!cmp_bytes_init(&in, data, in_length)) return NULL;++    uint32_t size = 0;+    if (!cmp_read_array(&in, &size) || size < 1 || size > 2) return NULL;+    FcPattern *p = decodePattern(&in);+    if (p == NULL) {cmp_bytes_take(&in, NULL); return NULL;}+    FcPattern *p_pat = NULL;+    if (size == 2) {+        p_pat = decodePattern(&in);+        if (p_pat == NULL) {cmp_bytes_take(&in, NULL); goto fail;}+    }+    cmp_bytes_take(&in, NULL);++    if (!FcConfigSubstituteWithPat(conf, p, p_pat, isFont ? FcMatchFont : FcMatchPattern)) goto fail;++    cmp_ctx_t out;+    if (!cmp_bytes_alloc(&out, 1024)) goto fail;+    if (!encodePattern(&out, p)) goto fail;+    FcPatternDestroy(p);+    if (p_pat != NULL) FcPatternDestroy(p_pat);+    return cmp_bytes_take(&out, length);++fail:+    FcPatternDestroy(p);+    if (p_pat != NULL) FcPatternDestroy(p_pat);+    return NULL;+}++uint8_t *fcFontMatch(FcConfig *conf, uint8_t *data, size_t in_length, size_t *length) {+    cmp_ctx_t in;+    if (!cmp_bytes_init(&in, data, in_length)) return NULL;+    FcPattern *p = decodePattern(&in);+    cmp_bytes_take(&in, NULL);+    if (p == NULL) return NULL;++    if (!FcConfigSubstitute(conf, p, FcMatchPattern)) goto fail;+    FcDefaultSubstitute(p);++    FcResult err;+    FcPattern *res = FcFontMatch(conf, p, &err);+    if (res == NULL) goto fail;++    cmp_ctx_t out;+    if (!cmp_bytes_alloc(&out, 1024)) goto fail;+    if (err != FcResultMatch) {+        if (!encodeResult(&out, err)) goto fail2;+    } else {+        if (!encodePattern(&out, res)) goto fail2;+    }+    FcPatternDestroy(p);+    return cmp_bytes_take(&out, length);;++fail2:+    cmp_bytes_free(&out);+fail:+    FcPatternDestroy(p);+    return NULL;+}++uint8_t *fcFontSort(FcConfig *conf, uint8_t *data, size_t in_length, bool trim, size_t *length) {+    cmp_ctx_t in;+    if (!cmp_bytes_init(&in, data, in_length)) return NULL;+    FcPattern *p = decodePattern(&in);+    cmp_bytes_take(&in, NULL);+    if (p == NULL) return NULL;++    if (!FcConfigSubstitute(conf, p, FcMatchPattern)) goto fail;+    FcDefaultSubstitute(p);++    FcResult err;+    FcCharSet *csp;+    FcFontSet *res = FcFontSort(conf, p, trim, &csp, &err);+    if (res == NULL) goto fail2;++    cmp_ctx_t out;+    if (!cmp_bytes_alloc(&out, 1024)) goto fail2;+    if (err != FcResultMatch) {+        if (!encodeResult(&out, err)) goto fail3;+    } else if (csp != NULL) {+        if (!cmp_write_array(&out, 2)) goto fail3;+        if (!encodeFontSet(&out, res)) goto fail3;+        if (!encodeCharSet(&out, csp)) goto fail3;+    } else {+        if (!cmp_write_array(&out, 2)) goto fail3;+        if (!encodeFontSet(&out, res)) goto fail3;+        if (!cmp_write_array(&out, 0)) goto fail3;+    }+    FcPatternDestroy(p);+    if (csp != NULL) FcCharSetDestroy(csp);+    return cmp_bytes_take(&out, length);++fail3:+    cmp_bytes_free(&out);+fail2:+    if (csp != NULL) FcCharSetDestroy(csp);+fail:+    FcPatternDestroy(p);+    return NULL;+}++uint8_t *fcFontRenderPrepare(FcConfig *conf, uint8_t *data, size_t in_length, size_t *length) {+    cmp_ctx_t in;+    if (!cmp_bytes_init(&in, data, in_length)) return NULL;+    uint32_t size = 0;+    if (!cmp_read_array(&in, &size) || size != 2) return NULL;+    FcPattern *pat = decodePattern(&in);+    if (pat == NULL) {cmp_bytes_take(&in, NULL); return NULL;}+    FcPattern *font = decodePattern(&in);+    cmp_bytes_take(&in, NULL);+    if (font == NULL) {FcPatternDestroy(pat); return NULL; }++    FcPattern *res = FcFontRenderPrepare(conf, pat, font);+    if (res == NULL) goto fail0;++    cmp_ctx_t out;+    if (!cmp_bytes_alloc(&out, 1024)) goto fail;+    if (!encodePattern(&out, res)) {cmp_bytes_free(&out); goto fail;}+    FcPatternDestroy(pat);+    FcPatternDestroy(font);+    FcPatternDestroy(res);+    return cmp_bytes_take(&out, length);++fail:+    FcPatternDestroy(res);+fail0:+    FcPatternDestroy(pat);+    FcPatternDestroy(font);+    return NULL;+}++uint8_t *fcFontList(FcConfig *conf, uint8_t *data, size_t in_length, size_t *length) {+    cmp_ctx_t in;+    if (!cmp_bytes_init(&in, data, in_length)) return NULL;+    uint32_t size = 0;+    if (!cmp_read_array(&in, &size) || size != 2) {+        cmp_bytes_take(&in, NULL);+        return NULL;+    }+    FcPattern *pat = decodePattern(&in);+    if (pat == NULL) {cmp_bytes_take(&in, NULL); return NULL;}+    FcObjectSet *os = decodeObjectSet(&in);+    cmp_bytes_take(&in, NULL);+    if (os == NULL) {FcPatternDestroy(pat); return NULL;}++    FcFontSet *res = FcFontList(conf, pat, os);+    if (res == NULL) goto fail0;++    cmp_ctx_t out;+    if (!cmp_bytes_alloc(&out, 1024)) goto fail;+    if (!encodeFontSet(&out, res)) { cmp_bytes_free(&out); goto fail;}+    FcFontSetDestroy(res);+    return cmp_bytes_take(&out, length);++fail:+    FcFontSetDestroy(res);+fail0:+    FcPatternDestroy(pat);+    FcObjectSetDestroy(os);+    return NULL;+}++/*int fcConfigAcceptFont(FcConfig *conf, uint8_t *data, size_t length) {+    cmp_ctx_t in;+    if (!cmp_bytes_init(&in, data, length)) return -1;+    FcPattern *pat = decodePattern(&in);+    if (pat == NULL) return -1;++    FcBool ret = FcConfigAcceptFont(conf, pat);+    FcPatternDestroy(pat);+    return ret ? 1 : 0;+}*/
+ cbits/fontconfig-wrap.h view
@@ -0,0 +1,39 @@+#include <fontconfig/fontconfig.h>+#include <fontconfig/fcfreetype.h>+#include <stdint.h>+#include <stdbool.h>++int fcPatternEqualSubset(uint8_t *data, size_t length);+uint8_t *fcDefaultSubstitute(uint8_t *data, size_t in_length, size_t *length);+uint8_t *fcNameParse(char *name, size_t *length);+char *fcNameUnparse(uint8_t *data, size_t length);+char *fcNameFormat(uint8_t *data, size_t length, char *format);+uint8_t *fcFontSetList(FcConfig *config, uint8_t *sets, size_t sets_length,+        uint8_t *pat, size_t pat_length, uint8_t *objects, size_t objs_length, size_t *length);+uint8_t *fcFontSetMatch(FcConfig *config, uint8_t *sets, size_t sets_length,+        uint8_t *pat, size_t pat_length, size_t *length);+uint8_t *fcFontSetSort(FcConfig *config, uint8_t *sets, size_t sets_length,+        uint8_t *pat, size_t pat_length, bool trim, size_t *length);+unsigned int fcFreeTypeCharIndex(FT_Face *face, uint32_t ucs4);+uint8_t *fcFreeTypeCharSet(FT_Face *face, size_t *length);+uint8_t *fcFreeTypeCharSetAndSpacing(FT_Face *face, size_t *length);+uint8_t *fcFreeTypeQuery(char *file, int id, size_t *length);+uint8_t *fcFreeTypeQueryAll(char *file, size_t *length);+uint8_t *fcFreeTypeQueryFace(FT_Face *face, char *file, int id, size_t *length);+int fcLangSetCompare(uint8_t *langset, size_t length);+int fcLangSetHasLang(uint8_t *langset, size_t length, const char *lang);+uint8_t *fcGetDefaultLangs(size_t *length);+uint8_t *fcGetLangs(size_t *length);+char *fcLangNormalize(char *lang);+uint8_t *fcLangGetCharSet(const char *lang, size_t *length);+uint8_t *fcConfigGetConfigDirs(FcConfig *conf, size_t *length);+uint8_t *fcConfigGetFontDirs(FcConfig *conf, size_t *length);+uint8_t *fcConfigGetConfigFiles(FcConfig *conf, size_t *length);+uint8_t *fcConfigGetCacheDirs(FcConfig *conf, size_t *length);+uint8_t *fcConfigGetFonts(FcConfig *conf, bool system, size_t *length);+uint8_t *fcConfigSubstituteWithPat(FcConfig *conf, uint8_t *data, size_t in_length, bool isFont, size_t *length);+uint8_t *fcFontMatch(FcConfig *conf, uint8_t *data, size_t in_length, size_t *length);+uint8_t *fcFontSort(FcConfig *conf, uint8_t *data, size_t in_length, bool trim, size_t *length);+uint8_t *fcFontRenderPrepare(FcConfig *conf, uint8_t *data, size_t in_length, size_t *length);+uint8_t *fcFontList(FcConfig *conf, uint8_t *data, size_t in_length, size_t *length);+
− cbits/pattern.c 
@@ -1,37 +0,0 @@-#include <fontconfig/fontconfig.h>-#include <stddef.h>--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];-}
+ cbits/transcode.c view
@@ -0,0 +1,766 @@+#include "cmp.h"+#include <fontconfig/fontconfig.h>+#include <assert.h>+#include <string.h>+#include <stdlib.h>+#include <stdio.h>++struct bytes {+    uint8_t *start;+    size_t offset;+    size_t length;+};++bool bytes_reader(struct cmp_ctx_s *ctx, void *data, size_t limit) {+    struct bytes *bytes = ctx->buf;+    if (bytes->offset + limit > bytes->length) return false;+    memcpy(data, bytes->start + bytes->offset, limit);+    bytes->offset += limit;+    return true;+}++bool bytes_skipper(struct cmp_ctx_s *ctx, size_t count) {+    struct bytes *bytes = ctx->buf;+    if (bytes->offset + count > bytes->length) return false;+    bytes->offset += count;+    return true;+}++size_t bytes_writer(struct cmp_ctx_s *ctx, const void *data, size_t count) {+    struct bytes *bytes = ctx->buf;+    if (bytes->offset + count > bytes->length) {+        bytes->start = realloc(bytes->start, 2*bytes->length);+        if (bytes->start == NULL) return 0;+        bytes->length = 2*bytes->length;+    }+    memcpy(bytes->start + bytes->offset, data, count);+    bytes->offset += count;+    return count;+}++bool cmp_bytes_init(cmp_ctx_t *ctx, uint8_t *buf, size_t length) {+    struct bytes *inner = malloc(sizeof(struct bytes));+    if (inner == NULL) return false;+    inner->start = buf;+    inner->offset = 0;+    inner->length = length;+    cmp_init(ctx, inner, bytes_reader, bytes_skipper, bytes_writer);+    return true;+}++bool cmp_bytes_alloc(cmp_ctx_t *ctx, size_t length) {+    uint8_t *bytes = malloc(length);+    if (bytes == NULL) return false;+    return cmp_bytes_init(ctx, bytes, length);+}++void cmp_bytes_free(cmp_ctx_t *ctx) {+    struct bytes *bytes = ctx->buf;+    free(bytes->start);+    free(bytes);+}++uint8_t *cmp_bytes_take(cmp_ctx_t *ctx, size_t *length) {+    struct bytes *bytes = ctx->buf;+    uint8_t *ret = bytes->start;+    if (length != NULL) *length = bytes->offset;+    free(bytes);+    return ret;+}++// The encoders, decoders, & (for testing) round-trip routines themselves!++FcStrSet *decodeStrSet(cmp_ctx_t *bytes) {+    if (bytes == NULL) return NULL;++    uint32_t size;+    if (!cmp_read_array(bytes, &size)) return NULL;++    FcStrSet *ret = FcStrSetCreate();+    if (ret == NULL) return NULL;++    for (uint32_t i = 0; i < size; i++) {+        char text[512]; // What's the appropriate size here?+        uint32_t str_size = 512;+        if (!cmp_read_str(bytes, text, &str_size)) goto fail;+        if (!FcStrSetAdd(ret, text)) goto fail;+    }+    return ret;+fail:+    FcStrSetDestroy(ret);+    return NULL;+}++FcStrSet *decodeFileSet(cmp_ctx_t *bytes) {+    if (bytes == NULL) return NULL;++    uint32_t size;+    if (!cmp_read_array(bytes, &size)) return NULL;++    FcStrSet *ret = FcStrSetCreate();+    if (ret == NULL) return NULL;++    for (uint32_t i = 0; i < size; i++) {+        char text[512]; // What's the appropriate size here?+        uint32_t str_size = 512;+        if (!cmp_read_str(bytes, text, &str_size)) goto fail;+        if (!FcStrSetAddFilename(ret, text)) goto fail;+    }+    return ret;+fail:+    FcStrSetDestroy(ret);+    return NULL;+}++bool encodeStrList(cmp_ctx_t *bytes, FcStrList *iter) {+    uint32_t size = 0;+    FcStrListFirst(iter);+    while (FcStrListNext(iter) != NULL) size++;+    if (!cmp_write_array(bytes, size)) return false;++    FcStrListFirst(iter);+    char *text = FcStrListNext(iter);+    while (text != NULL) {+        if (!cmp_write_str(bytes, text, strlen(text))) return false;+        text = FcStrListNext(iter);+    }+    return true;+}++bool encodeStrSet(cmp_ctx_t *bytes, FcStrSet *data) {+    if (bytes == NULL || data == NULL) return false;++    FcStrList *iter = FcStrListCreate(data);+    if (iter == NULL) return false;++    bool ret = encodeStrList(bytes, iter);+    FcStrListDone(iter);+    return ret;+}++uint8_t *testStrSet(uint8_t *in, size_t in_length, size_t *length) {+    if (in == NULL) return NULL;++    cmp_ctx_t bytes;+    if (!cmp_bytes_init(&bytes, in, in_length)) return false;+    FcStrSet *decoded = decodeStrSet(&bytes);+    cmp_bytes_take(&bytes, NULL);+    if (decoded == NULL) return NULL;++    if (!cmp_bytes_alloc(&bytes, in_length)) {FcStrSetDestroy(decoded); goto fail;}+    bool ok = encodeStrSet(&bytes, decoded);+    FcStrSetDestroy(decoded);+    if (ok) return cmp_bytes_take(&bytes, length);+    else {+fail:+        cmp_bytes_free(&bytes);+        return NULL;+    }+}++FcCharSet *decodeObjCharSet(cmp_ctx_t *bytes, cmp_object_t *head, cmp_object_t *first) {+    if (bytes == NULL || head == NULL) return NULL;++    int8_t type; uint32_t size;+    if (cmp_object_as_ext(head, &type, &size) && type == 'c' && size == 0)+        return FcCharSetCreate(); // Special unambiguous empty encoding!+    else if (!cmp_object_as_array(head, &size)) return NULL;++    FcCharSet *ret = FcCharSetCreate();+    if (ret == NULL) return NULL;++    FcChar32 prev = 0;+    /* Allow peek-ahead to different based on type inside list */+    if (size > 0 && first != NULL) {+        if (!cmp_object_as_uint(first, &prev)) goto fail;+        if (!FcCharSetAddChar(ret, prev)) goto fail;+        size--; // We've read the first entry of the array!+    }++    /* The proper decoding! Diff-compressed to minimize temp-memory used. */+    for (uint32_t i = 0; i < size; i++) {+        uint32_t x;+        if (!cmp_read_uint(bytes, &x)) goto fail;+        prev += x;+        if (!FcCharSetAddChar(ret, prev)) goto fail;+    }+    return ret;+fail:+    FcCharSetDestroy(ret);+    return NULL;+}++FcCharSet *decodeCharSet(cmp_ctx_t *bytes) {+    if (bytes == NULL) return NULL;++    cmp_object_t head;+    if (!cmp_read_object(bytes, &head)) return NULL;+    return decodeObjCharSet(bytes, &head, NULL);+}++bool encodeCharSet(cmp_ctx_t *bytes, const FcCharSet *data) {+    if (bytes == NULL || data == NULL) return false;++    FcChar32 size = FcCharSetCount(data);+    if (size == 0) { // Unambiguous empty encoding!+        return cmp_write_ext_marker(bytes, 'c', 0);+    }+    FcChar32 count = 0; // For validation+    if (!cmp_write_array(bytes, size)) return false;++    FcChar32 map[FC_CHARSET_MAP_SIZE];+    FcChar32 next;+    FcChar32 base = FcCharSetFirstPage(data, map, &next);+    FcChar32 prev = 0;+    while (base != FC_CHARSET_DONE) {+        for (unsigned int i = 0; i < FC_CHARSET_MAP_SIZE; i++) for (unsigned int j = 0; j < 32; j++) {+            if (map[i] & (1 << j)) {+                FcChar32 c = base + i*32 + j;+                if (!cmp_write_uinteger(bytes, c - prev)) return false;+                prev = c;+                count++;+            }+        }+        base = FcCharSetNextPage(data, map, &next);+    }+    //assert(size == count);+    return true;+}++uint8_t *testCharSet(uint8_t *in, size_t in_length, size_t *length) {+    if (in == NULL) return NULL;++    cmp_ctx_t bytes;+    if (!cmp_bytes_init(&bytes, in, in_length)) return false;+    FcCharSet *decoded = decodeCharSet(&bytes);+    cmp_bytes_take(&bytes, NULL);+    if (decoded == NULL) {return NULL;}++    if (!cmp_bytes_alloc(&bytes, in_length)) {+        FcCharSetDestroy(decoded);+        goto fail;+    }+    bool ok = encodeCharSet(&bytes, decoded);+    FcCharSetDestroy(decoded);+    if (ok) return cmp_bytes_take(&bytes, length);+    else {+fail:+        cmp_bytes_free(&bytes);+        return NULL;+    }+}++FcLangSet *decodeObjLangSet(cmp_ctx_t *bytes, cmp_object_t *head, cmp_object_t *first) {+    uint32_t size = 0;+    if (bytes == NULL || head == NULL || !cmp_object_as_array(head, &size)) return NULL;++    FcLangSet *ret = FcLangSetCreate();+    if (ret == NULL) return NULL;++    /* Allow peek ahead to differentiate based on type stored in list */+    if (first != NULL && size > 0) {+        #define LANG_BUF_SZ 32 // If I'm reading FontConfig code right, 16's enough, but be generous...+        char buf[LANG_BUF_SZ];+        if (!cmp_object_to_str(bytes, first, buf, LANG_BUF_SZ)) goto fail;+        char *lang = FcLangNormalize(buf);+        if (lang == NULL) goto fail;+        if (!FcLangSetAdd(ret, lang)) {free(lang); goto fail;}+        free(lang);+        size--;+    }++    /* The proper decoding! */+    for (uint32_t i = 0; i < size; i++) {+        char lang[10];+        uint32_t str_size = 10;+        if (!cmp_read_str(bytes, lang, &str_size)) goto fail;+        char *lang2 = FcLangNormalize(lang);+        if (lang2 == NULL) goto fail;+        if (!FcLangSetAdd(ret, lang2)) {free(lang2); goto fail;}+        free(lang2);+    }+    return ret;+fail:+    FcLangSetDestroy(ret);+    return NULL;+}++FcLangSet *decodeLangSet(cmp_ctx_t *bytes) {+    if (bytes == NULL) return NULL;+    cmp_object_t head;+    if (!cmp_read_object(bytes, &head)) return NULL;+    return decodeObjLangSet(bytes, &head, NULL);+}++bool encodeLangSet(cmp_ctx_t *bytes, const FcLangSet *data) {+    if (bytes == NULL || data == NULL) return false;+    FcStrSet *langs = FcLangSetGetLangs(data);+    if (langs == NULL) return false;+    bool ret = encodeStrSet(bytes, langs);+    FcStrSetDestroy(langs);+    return ret;+}++uint8_t *testLangSet(uint8_t *in, size_t in_length, size_t *length) {+    if (in == NULL) return NULL;++    cmp_ctx_t bytes;+    if (!cmp_bytes_init(&bytes, in, in_length)) return false;+    FcLangSet *decoded = decodeLangSet(&bytes);+    cmp_bytes_take(&bytes, NULL);+    if (decoded == NULL) return NULL;++    if (!cmp_bytes_alloc(&bytes, in_length)) {+        FcLangSetDestroy(decoded);+        goto fail;+    }+    bool ok = encodeLangSet(&bytes, decoded);+    FcLangSetDestroy(decoded);+    if (ok) return cmp_bytes_take(&bytes, length);+    else {+fail:+        cmp_bytes_free(&bytes);+        return NULL;+    }+}++FcObjectSet *decodeObjectSet(cmp_ctx_t *bytes) {+    if (bytes == NULL) return NULL;++    uint32_t size;+    if (!cmp_read_array(bytes, &size)) return NULL;++    FcObjectSet *ret = FcObjectSetCreate();+    for (uint32_t i = 0; i < size; i++) {+        char object[20];+        uint32_t o_size = 20;+        if (!cmp_read_str(bytes, object, &o_size)) goto fail;+        if (!FcObjectSetAdd(ret, object)) goto fail;+    }+    return ret;+fail:+    FcObjectSetDestroy(ret);+    return NULL;+}++// No corresponding objectset encoder.++FcRange *decodeObjRange(cmp_ctx_t *bytes, cmp_object_t *head) {+    uint32_t size = 0;+    if (bytes == NULL || head == NULL || !cmp_object_as_map(head, &size)) return NULL;++    double range[2];+    for (uint32_t i = 0; i < size; i++) {+        uint32_t j;+        if (!cmp_read_uint(bytes, &j)) return NULL;+        if (!cmp_read_double(bytes, &range[j])) return NULL;+    }+    return FcRangeCreateDouble(range[0], range[1]);+}++FcRange *decodeRange(cmp_ctx_t *bytes) {+    if (bytes == NULL) return NULL;++    cmp_object_t head;+    if (!cmp_read_object(bytes, &head)) return NULL;+    return decodeObjRange(bytes, &head);+}++bool encodeRange(cmp_ctx_t *bytes, const FcRange *data) {+    if (bytes == NULL || data == NULL) return false;++    double begin, end;+    if (!FcRangeGetDouble(data, &begin, &end)) return false;++    if (!cmp_write_map(bytes, 2)) return false;+    if (!cmp_write_uint(bytes, 0)) return false;+    if (!cmp_write_double(bytes, begin)) return false;+    if (!cmp_write_uint(bytes, 1)) return false;+    if (!cmp_write_double(bytes, end)) return false;+    return true;+}++uint8_t *testRange(uint8_t *in, size_t in_length, size_t *length) {+    if (in == NULL) return NULL;++    cmp_ctx_t bytes;+    if (!cmp_bytes_init(&bytes, in, in_length)) return false;+    FcRange *decoded = decodeRange(&bytes);+    cmp_bytes_take(&bytes, NULL);+    if (decoded == NULL) return NULL;++    if (!cmp_bytes_alloc(&bytes, in_length)) {FcRangeDestroy(decoded); goto fail;}+    bool ok = encodeRange(&bytes, decoded);+    FcRangeDestroy(decoded);+    if (ok) return cmp_bytes_take(&bytes, length);+    else {+fail:+        cmp_bytes_free(&bytes);+        return NULL;+    }+}++FcMatrix *decodeObjMatrix(cmp_ctx_t *bytes, cmp_object_t *head, cmp_object_t *next) {+    uint32_t size = 0;+    if (bytes == NULL || head == NULL) return NULL;+    if (!cmp_object_as_array(head, &size) || size != 4) return NULL;++    cmp_object_t first;+    if (next == NULL) {+        if (!cmp_read_object(bytes, &first)) return NULL;+    } else first = *next;+    if (!cmp_object_is_double(&first)) return NULL;++    FcMatrix *ret = malloc(sizeof(FcMatrix));+    if (ret == NULL) return NULL;+    if (!cmp_object_as_double(&first, &ret->xx)) goto fail;+    if (!cmp_read_double(bytes, &ret->xy)) goto fail;+    if (!cmp_read_double(bytes, &ret->yx)) goto fail;+    if (!cmp_read_double(bytes, &ret->yy)) goto fail;+    return ret;+fail:+    free(ret);+    return NULL;+}++FcMatrix *decodeMatrix(cmp_ctx_t *bytes) {+    if (bytes == NULL) return NULL;++    cmp_object_t head;+    if (!cmp_read_object(bytes, &head)) return NULL;+    return decodeObjMatrix(bytes, &head, NULL);+}++bool encodeMatrix(cmp_ctx_t *bytes, const FcMatrix *data) {+    if (bytes == NULL || data == NULL) return NULL;++    if (!cmp_write_array(bytes, 4)) return false;+    if (!cmp_write_double(bytes, data->xx)) return false;+    if (!cmp_write_double(bytes, data->xy)) return false;+    if (!cmp_write_double(bytes, data->yx)) return false;+    if (!cmp_write_double(bytes, data->yy)) return false;+    return true;+}++uint8_t *testMatrix(uint8_t *in, size_t in_length, size_t *length) {+    if (in == NULL) return NULL;++    cmp_ctx_t bytes;+    if (!cmp_bytes_init(&bytes, in, in_length)) return false;+    FcMatrix *decoded = decodeMatrix(&bytes);+    cmp_bytes_take(&bytes, NULL);+    if (decoded == NULL) return NULL;++    if (!cmp_bytes_alloc(&bytes, in_length)) {free(decoded); goto fail;}+    bool ok = encodeMatrix(&bytes, decoded);+    free(decoded);+    if (ok) return cmp_bytes_take(&bytes, length);+    else {+fail:+        cmp_bytes_free(&bytes);+        return NULL;+    }+}++bool decodeValue(cmp_ctx_t *bytes, FcValue *out) {+    if (bytes == NULL || out == NULL) return false;++    cmp_object_t head;+    if (!cmp_read_object(bytes, &head)) return NULL;+    bool b;+    uint32_t size;+    if (head.type == CMP_TYPE_NIL) out->type = FcTypeVoid;+    else if (cmp_object_as_int(&head, &out->u.i)) out->type = FcTypeInteger;+    else if (cmp_object_as_double(&head, &out->u.d)) out->type = FcTypeDouble;+    else if (cmp_object_as_str(&head, &size)) {+        out->type = FcTypeString;+        size++; // Include space for Nil byte!+        char *str = malloc(size);+        out->u.s = str;+        bool ok = cmp_object_to_str(bytes, &head, str, size);+        if (!ok) free(str);+        return ok;+    } else if (cmp_object_as_bool(&head, &b)) {+        out->type = FcTypeBool;+        out->u.b = b ? FcTrue : FcFalse; // Didn't auto-convert.+    } else if (cmp_object_as_array(&head, &size)) {+        cmp_object_t *first = NULL;+        cmp_object_t first_;+        if (size > 0) {+            first = &first_;+            if (!cmp_read_object(bytes, first)) return false;+        }+        if ((out->u.m = decodeObjMatrix(bytes, &head, first)) != NULL)+            out->type = FcTypeMatrix;+        // For ease of encoding empty lists are treated as lang sets.+        // Hence LangSets take priority during decode!+        else if ((out->u.l = decodeObjLangSet(bytes, &head, first)) != NULL)+            out->type = FcTypeLangSet;+        else if ((out->u.c = decodeObjCharSet(bytes, &head, first)) != NULL)+            out->type = FcTypeCharSet;+    } // Not supporting FcTypeFcFace+    else if ((out->u.r = decodeObjRange(bytes, &head)) != NULL)+        out->type = FcTypeRange;+    else return false;+    return true;+}++bool encodeValue(cmp_ctx_t *bytes, FcValue *data) {+    if (bytes == NULL || data == NULL) return false;++    switch (data->type) {+    case FcTypeVoid:+        return cmp_write_nil(bytes);+    case FcTypeInteger:+        return cmp_write_int(bytes, data->u.i);+    case FcTypeDouble:+        return cmp_write_double(bytes, data->u.d);+    case FcTypeString:+        return cmp_write_str(bytes, data->u.s, strlen(data->u.s));+    case FcTypeBool:+        return cmp_write_bool(bytes, data->u.b);+    case FcTypeMatrix:+        return encodeMatrix(bytes, data->u.m);+    case FcTypeCharSet:+        return encodeCharSet(bytes, data->u.c);+    case FcTypeFTFace:+        return true; // Not supporting this yet...+    case FcTypeLangSet:+        return encodeLangSet(bytes, data->u.l);+    case FcTypeRange:+        return encodeRange(bytes, data->u.r);+    default:+        return false;+    }+}++uint8_t *testValue(uint8_t *in, size_t in_length, size_t *length) {+    if (in == NULL) return NULL;++    cmp_ctx_t bytes;+    if (!cmp_bytes_init(&bytes, in, in_length)) return false;+    FcValue decoded;+    bool ok = decodeValue(&bytes, &decoded);+    cmp_bytes_take(&bytes, NULL);+    if (!ok) return NULL;++    if (!cmp_bytes_alloc(&bytes, in_length)) {FcValueDestroy(decoded); goto fail;}+    ok = encodeValue(&bytes, &decoded);+    FcValueDestroy(decoded);+    if (ok) return cmp_bytes_take(&bytes, length);+    else {+fail:+        cmp_bytes_free(&bytes);+        return NULL;+    }+}++FcPattern *decodePattern(cmp_ctx_t *bytes) {+    if (bytes == NULL) return NULL;++    uint32_t size;+    if (!cmp_read_map(bytes, &size)) return NULL;++    FcPattern *ret = FcPatternCreate();+    if (ret == NULL) return NULL;+    for (uint32_t i = 0; i < size; i++) {+        char object[20];+        uint32_t osize = 20;+        if (!cmp_read_str(bytes, object, &osize)) goto fail;+        uint32_t vsize;+        if (!cmp_read_array(bytes, &vsize)) goto fail;+        for (uint32_t j = 0; j < vsize; j++) {+            uint32_t tsize;+            if (!cmp_read_array(bytes, &tsize) || tsize != 2) goto fail;++            cmp_object_t strength;+            if (!cmp_read_object(bytes, &strength)) goto fail;+            bool is_strong = false;+            if (cmp_object_as_bool(&strength, &is_strong)) {}+            else if (cmp_object_is_nil(&strength)) {}+            else goto fail;++            FcValue val;+            if (!decodeValue(bytes, &val)) goto fail;+            //FcValuePrint(val);+            if (is_strong) {+                if (!FcPatternAdd(ret, object, val, true)) {FcValuePrint(val); goto fail;}+            } else {+                if (!FcPatternAddWeak(ret, object, val, true)) {FcValuePrint(val); goto fail;}+            }+            FcValueDestroy(val);+        }+    }+    return ret;+fail:+    FcPatternDestroy(ret);+    return NULL;+}++bool encodePattern(cmp_ctx_t *bytes, FcPattern *data) {+    if (bytes == NULL || data == NULL) return false;++    int size = FcPatternObjectCount(data);+    if (!cmp_write_map(bytes, size)) return false;++    FcPatternIter iter;+    FcPatternIterStart(data, &iter);+    int count = 0;+    do {+        count++;+        const char *obj = FcPatternIterGetObject(data, &iter);+        if (!cmp_write_str(bytes, obj, strlen(obj))) return false;+        int nvalues = FcPatternIterValueCount(data, &iter);+        if (!cmp_write_array(bytes, nvalues)) return false;+        for (int j = 0; j < nvalues; j++) {+            FcValue val;+            FcValueBinding weight;+            if (FcPatternIterGetValue(data, &iter, j, &val, &weight) != FcResultMatch)+                return false;++            if (!cmp_write_array(bytes, 2)) return false;+            switch (weight) {+            case FcValueBindingWeak:+                if (!cmp_write_bool(bytes, false)) return false;+                break;+            case FcValueBindingStrong:+                if (!cmp_write_bool(bytes, true)) return false;+                break;+            case FcValueBindingSame:+                if (!cmp_write_nil(bytes)) return false;+                break;+            default:+                return false;+            }+            if (!encodeValue(bytes, &val)) return false;+        }+    } while (FcPatternIterNext(data, &iter));+    assert(size == count);+    return true;+}++uint8_t *testPattern(uint8_t *in, size_t in_length, size_t *length) {+    if (in == NULL) return NULL;++    cmp_ctx_t bytes;+    if (!cmp_bytes_init(&bytes, in, in_length)) return false;+    FcPattern *decoded = decodePattern(&bytes);+    cmp_bytes_take(&bytes, NULL);+    if (decoded == NULL) return NULL;++    if (!cmp_bytes_alloc(&bytes, in_length)) {FcPatternDestroy(decoded); goto fail;}+    bool ok = encodePattern(&bytes, decoded);+    FcPatternDestroy(decoded);+    if (ok) return cmp_bytes_take(&bytes, length);+    else {+fail:+        cmp_bytes_free(&bytes);+        return NULL;+    }+}++FcFontSet *decodeFontSet(cmp_ctx_t *bytes) {+    if (bytes == NULL) return NULL;++    uint32_t size;+    if (!cmp_read_array(bytes, &size)) return NULL;++    FcFontSet *ret = FcFontSetCreate();+    if (ret == NULL) return NULL;++    for (uint32_t i = 0; i < size; i++) {+        FcPattern *font = decodePattern(bytes);+        if (font == NULL) goto fail;+        if (!FcFontSetAdd(ret, font)) goto fail;+    }+    return ret;+fail:+    FcFontSetDestroy(ret);+    return NULL;+}++FcFontSet **decodeFontSets(cmp_ctx_t *bytes, size_t *nsets) {+    if (bytes == NULL) return NULL;++    uint32_t size;+    if (!cmp_read_array(bytes, &size)) return NULL;+    if (nsets != NULL) *nsets = size;++    FcFontSet **ret = calloc(sizeof(FcFontSet *), size);+    uint32_t i;+    for (i = 0; i < size; i++) {+        ret[i] = decodeFontSet(bytes);+        if (ret[i] == NULL) goto fail;+        i++;+    }+    return ret;+fail:+    for (uint32_t j = 0; j < i; j++) FcFontSetDestroy(ret[j]);+    free(ret);+    return NULL;+}++bool encodeFontSet(cmp_ctx_t *bytes, FcFontSet *data) {+    if (bytes == NULL || data == NULL) return NULL;++    if (!cmp_write_array(bytes, data->nfont)) return false;+    for (int i = 0; i < data->nfont; i++) {+        if (!encodePattern(bytes, data->fonts[i])) return false;+    }+    return true;+}++uint8_t *testFontSet(uint8_t *in, size_t in_length, size_t *length) {+    if (in == NULL) return NULL;++    cmp_ctx_t bytes;+    if (!cmp_bytes_init(&bytes, in, in_length)) return false;+    FcFontSet *decoded = decodeFontSet(&bytes);+    cmp_bytes_take(&bytes, NULL);+    if (decoded == NULL) return NULL;++    if (!cmp_bytes_alloc(&bytes, in_length)) {+        FcFontSetDestroy(decoded);+        goto fail;+    }+    bool ok = encodeFontSet(&bytes, decoded);+    FcFontSetDestroy(decoded);+    if (ok) return cmp_bytes_take(&bytes, length);+    else {+fail:+        cmp_bytes_free(&bytes);+        return NULL;+    }+}++bool encodeRenderableFontSet(cmp_ctx_t *bytes, FcConfig *conf, FcPattern *pat, FcFontSet *data) {+    if (bytes == NULL || data == NULL) return false;++    if (!cmp_write_array(bytes, data->nfont)) return false;+    for (int i = 0; i < data->nfont; i++) {+        FcPattern *postprocessed = FcFontRenderPrepare(conf, pat, data->fonts[i]);+        if (postprocessed == NULL) return false;++        bool ok = encodePattern(bytes, postprocessed);+        FcPatternDestroy(postprocessed);+        if (!ok) return false;+    }+    return true;+}++bool encodeResult(cmp_ctx_t *bytes, FcResult res) {+    switch (res) {+    case FcResultMatch: // Should be handled by caller! Can't do anything sensible here.+    case FcResultNoMatch: // May be handled by caller.+        return cmp_write_nil(bytes);+    case FcResultTypeMismatch:+        return cmp_write_str(bytes, "ErrType", strlen("ErrType"));+    case FcResultNoId:+        return cmp_write_str(bytes, "ErrNoId", strlen("ErrNoId"));+    case FcResultOutOfMemory:+        return cmp_write_str(bytes, "ErrOOM", strlen("ErrOOM"));+    default:+        // Should never happen!+        return cmp_write_str(bytes, "ErrOther", strlen("ErrOther"));+    }+}
+ cbits/transcode.h view
@@ -0,0 +1,38 @@+#include "cmp.h"+#include <fontconfig/fontconfig.h>++FcStrSet *decodeStrSet(cmp_ctx_t *bytes);+FcStrSet *decodeFileSet(cmp_ctx_t *bytes);+bool encodeStrSet(cmp_ctx_t *bytes, FcStrSet *data);+uint8_t *testStrSet(uint8_t *in, size_t in_length, size_t *length);+FcCharSet *decodeCharSet(cmp_ctx_t *bytes);+bool encodeStrList(cmp_ctx_t *bytes, const FcStrList *data);+bool encodeCharSet(cmp_ctx_t *bytes, const FcCharSet *data);+uint8_t *testCharSet(uint8_t *in, size_t in_length, size_t *length);+FcLangSet *decodeLangSet(cmp_ctx_t *bytes);+bool encodeLangSet(cmp_ctx_t *bytes, const FcLangSet *data);+uint8_t *testLangSet(uint8_t *in, size_t in_length, size_t *length);+FcObjectSet *decodeObjectSet(cmp_ctx_t *bytes);+FcRange *decodeRange(cmp_ctx_t *bytes);+bool encodeRange(cmp_ctx_t *bytes, const FcRange *data);+uint8_t *testRange(uint8_t *in, size_t in_length, size_t *length);+FcMatrix *decodeMatrix(cmp_ctx_t *bytes);+bool encodeMatrix(cmp_ctx_t *bytes, const FcMatrix *data);+uint8_t *testMatrix(uint8_t *in, size_t in_length, size_t *length);+bool decodeValue(cmp_ctx_t *bytes, FcValue *out);+bool encodeValue(cmp_ctx_t *bytes, FcValue *data);+uint8_t *testValue(uint8_t *in, size_t in_length, size_t *length);+FcPattern *decodePattern(cmp_ctx_t *bytes);+bool encodePattern(cmp_ctx_t *bytes, FcPattern *data);+uint8_t *testPattern(uint8_t *in, size_t in_length, size_t *length);+FcFontSet *decodeFontSet(cmp_ctx_t *bytes);+FcFontSet **decodeFontSets(cmp_ctx_t *bytes, size_t *nsets);+bool encodeFontSet(cmp_ctx_t *bytes, FcFontSet *data);+uint8_t *testFontSet(uint8_t *in, size_t in_length, size_t *length);+bool encodeRenderableFontSet(cmp_ctx_t *bytes, FcFontSet *data);+bool encodeResult(cmp_ctx_t *bytes, FcResult res);++bool cmp_bytes_init(cmp_ctx_t *ctx, uint8_t *buf, size_t length);+bool cmp_bytes_alloc(cmp_ctx_t *ctx, size_t length);+void cmp_bytes_free(cmp_ctx_t *ctx);+uint8_t *cmp_bytes_take(cmp_ctx_t *ctx, size_t *length);
fontconfig-pure.cabal view
@@ -1,109 +1,157 @@--- Initial fontconfig-pure.cabal generated by cabal init.  For further--- documentation, see http://haskell.org/cabal/users-guide/+cabal-version:      3.0+-- The cabal-version field refers to the version of the .cabal specification,+-- and can be different from the cabal-install (the tool) version and the+-- Cabal (the library) version you are using. As such, the Cabal (the library)+-- version used must be equal or greater than the version stated in this field.+-- Starting from the specification version 2.2, the cabal-version field must be+-- the first thing in the cabal file. +-- Initial package description 'fontconfig-pure' generated by+-- 'cabal init'. For further documentation, see:+--   http://haskell.org/cabal/users-guide/+-- -- The name of the package.-name:                fontconfig-pure+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.4.0.0+-- The package version.+-- See the Haskell package versioning policy (PVP) for standards+-- guiding when and how versions should be incremented.+-- https://pvp.haskell.org+-- PVP summary:     +-+------- breaking API changes+--                  | | +----- non-breaking API additions+--                  | | | +--- code changes with no API change+version:            0.5.1.0  -- A short (one-line) description of the package.-synopsis:            Pure-functional language bindings to FontConfig+synopsis:+    Queries your system (Linux/BSD/etc) font database.  -- A longer description of the package.-description:         Resolves font descriptions to font libraries, including ones installed on your freedesktop (Linux or BSD system).+description:	Resolves font descriptions to font libraries, including ones installed on your freedesktop (Linux or BSD system). With Haskell Stylist integration for CSS syntax!  -- URL for the project homepage or repository.-homepage:            https://www.freedesktop.org/wiki/Software/fontconfig/+homepage:           https://www.freedesktop.org/wiki/Software/fontconfig/  -- The license under which the package is released.-license:             MIT+license:            MIT  -- The file containing the license text.-license-file:        LICENSE+license-file:       LICENSE  -- The package author(s).-author:              Adrian Cochrane+author:             Adrian Cochrane --- An email address to which users can send suggestions, bug reports, and--- patches.-maintainer:          adrian@openwork.nz+-- An email address to which users can send suggestions, bug reports, and patches.+maintainer:          ~alcinnz/fontconfig-pure@todo.argonaut-constellation.org+bug-reports:         https://todo.argonaut-constellation.org/~alcinnz/fontconfig-pure  -- A copyright notice. -- copyright:--category:            Text+category:           Text+build-type:         Simple -build-type:          Simple+-- Extra doc files to be distributed with the package, such as a CHANGELOG or a README.+extra-doc-files:    CHANGELOG.md, README.md, cbits/SOURCES --- Extra files to be distributed with the package, such as examples or a--- README.-extra-source-files:  CHANGELOG.md+-- Extra source files to be distributed with the package, such as examples, or a tutorial module.+-- extra-source-files: --- Constraint on the version of Cabal needed to build this package.-cabal-version:       >=1.10+source-repository head+  type:     git+  location: https://git.argonaut-constellation.org/~alcinnz/fontconfig-pure +common warnings+    ghc-options: -Wall  library-  -- Modules exported by the library.-  exposed-modules:    Graphics.Text.Font.Choose, FreeType.FontConfig+    -- Import common warning flags.+    import:           warnings -  -- 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+    -- Modules exported by the library.+    exposed-modules:  Graphics.Text.Font.Choose.CharSet, Graphics.Text.Font.Choose.LangSet,+            Graphics.Text.Font.Choose.ObjectSet, Graphics.Text.Font.Choose.Range,+            Graphics.Text.Font.Choose.StrSet, Graphics.Text.Font.Choose.Value,+            Graphics.Text.Font.Choose.Pattern, Graphics.Text.Font.Choose.FontSet,+            Graphics.Text.Font.Choose.Config, Graphics.Text.Font.Choose.Result,+            Graphics.Text.Font.Choose.Internal.FFI, FreeType.FontConfig,+            Graphics.Text.Font.Choose.Config.Accessors, Graphics.Text.Font.Choose.Weight,+            Graphics.Text.Font.Choose.Internal.Test, Graphics.Text.Font.Choose -  c-sources:    cbits/pattern.c, cbits/charsetiter.c+    c-sources: cbits/cmp.c, cbits/cmp.h,+            cbits/transcode.c, cbits/transcode.h, cbits/fontconfig-wrap.c, cbits/fontconfig-wrap.h+    include-dirs: cbits -  -- LANGUAGE extensions used by modules in this package.-  -- other-extensions:+    pkgconfig-depends: fontconfig -  -- Other library packages from which modules are imported.-  build-depends:       base >=4.12 && <5, 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+    -- Modules included in this library but not exported.+    -- other-modules: -  pkgconfig-depends:    fontconfig+    -- LANGUAGE extensions used by modules in this package.+    -- other-extensions: -  -- Directories containing source files.-  -- hs-source-dirs:+    -- Other library packages from which modules are imported.+    build-depends:    base >=4.12 && <5, containers >=0.1 && <1, css-syntax,+            freetype2 >=0.2 && <0.3, hashable >=1.3 && <2, linear >=1.0.1 && <2,+            scientific >= 0.3.8 && < 1, text >= 2.0.2 && < 3, msgpack >= 1.0 && <2,+            vector >= 0.13 && <1, bytestring >= 0.11.5 && < 1,+            stylist-traits >=0.1.1 && <1, css-syntax >= 0.1.0 && < 0.2,+            QuickCheck >= 2.15.0 && < 2.16 -  -- Base language which the package is written in.-  default-language:    Haskell2010+    -- Directories containing source files.+    hs-source-dirs:   lib +    -- 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+    -- Import common warning flags.+    import:           warnings -  -- Modules included in this executable, other than Main.-  -- other-modules:+    -- .hs or .lhs file containing the Main module.+    main-is:          Main.hs -  -- LANGUAGE extensions used by modules in this package.-  -- other-extensions:+    -- Modules included in this executable, other than Main.+    -- other-modules: -  -- Other library packages from which modules are imported.-  build-depends:       base >=4.12 && <5, fontconfig-pure+    -- LANGUAGE extensions used by modules in this package.+    -- other-extensions: -  -- Directories containing source files.-  -- hs-source-dirs:+    -- Other library packages from which modules are imported.+    build-depends:+        base ^>=4.17.0.0,+        fontconfig-pure -  -- Base language which the package is written in.-  default-language:    Haskell2010+    -- Directories containing source files.+    hs-source-dirs:   app -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 && <5, fontconfig-pure, hspec, QuickCheck+    -- Base language which the package is written in.+    default-language: Haskell2010++test-suite fontconfig-pure-test+    -- Import common warning flags.+    import:           warnings++    -- Base language which the package is written in.+    default-language: Haskell2010++    -- Modules included in this executable, other than Main.+    -- other-modules:++    -- LANGUAGE extensions used by modules in this package.+    -- other-extensions:++    -- The interface type and version of the test suite.+    type:             exitcode-stdio-1.0++    -- Directories containing source files.+    hs-source-dirs:   test++    -- The entrypoint to the test suite.+    main-is:          Main.hs++    -- Test dependencies.+    build-depends:+        base ^>=4.17.0.0,+        fontconfig-pure,+        hspec, QuickCheck,+        msgpack, containers, text, css-syntax, stylist-traits
+ lib/FreeType/FontConfig.hs view
@@ -0,0 +1,376 @@+{-# LANGUAGE CApiFFI, OverloadedStrings #-}+-- | Convert between FontConfig & FreeType types.+module FreeType.FontConfig(charIndex,+        fontCharSet, fontCharSetAndSpacing, fontQuery, fontQueryAll, fontQueryFace,+        FTFC_Instance(..), FTFC_Metrics(..), FTFC_Subpixel(..), FTFC_Glyph(..),+        instantiatePattern, glyphForIndex, bmpAndMetricsForIndex) where++--import FreeType.Core.Base (FT_Face)++import Foreign.Ptr (Ptr)+import Foreign.C.String (CString)++import Graphics.Text.Font.Choose.CharSet (CharSet')+import Graphics.Text.Font.Choose.Pattern (Pattern, getValue, getValues)+import Graphics.Text.Font.Choose.FontSet (FontSet)+import Graphics.Text.Font.Choose.Internal.FFI (fromMessage0, withCString')++-- For FcFt transliteration+import Graphics.Text.Font.Choose.Value (Value(..))++import Data.Maybe (fromMaybe, fromJust)+import Linear.V2 (V2(..))+import Linear.Matrix(M22)+import Data.Bits ((.|.))+import Data.Word (Word32)++import Foreign.Storable (Storable(..))+import Control.Exception (catch, throw)+import Foreign.Marshal.Alloc (alloca)++import FreeType.Core.Base+import FreeType.Support.Outline (ft_Outline_Embolden)+import FreeType.Control.Subpixel (FT_LcdFilter, ft_Library_SetLcdFilter)+import FreeType.Core.Types+import FreeType.Exception (FtError(..))++-- | Maps a Unicode char to a glyph index. This function uses information from+-- several possible underlying encoding tables to work around broken fonts.+-- As a result, this function isn't designed to be used in performance sensitive areas;+-- results from this function are intended to be cached by higher level functions.+foreign import capi "fontconfig-wrap.h fcFreeTypeCharIndex" charIndex :: FT_Face -> Char -> Word++-- | Scans a FreeType face and returns the set of encoded Unicode chars.+fontCharSet :: FT_Face -> CharSet'+fontCharSet arg = fromMessage0 $ fcFreeTypeCharSet arg++foreign import capi "fontconfig-wrap.h" fcFreeTypeCharSet :: FT_Face -> Ptr Int -> CString++data Spacing = Mono -- ^ A font where all glyphs have the same width+    | Dual -- ^ The font has glyphs in precisely two widths+    | Proportional -- ^ The font has glyphs of many widths+    | SpacingError -- ^ Unexpected & invalid spacing value.+    deriving (Read, Show, Eq, Enum, Bounded)++-- | Scans a FreeType face and returns the set of encoded Unicode chars & the computed spacing type.+fontCharSetAndSpacing :: FT_Face -> (Spacing, CharSet')+fontCharSetAndSpacing arg = (toEnum spacing, chars)+  where (spacing, chars) = fromMessage0 $ fcFreeTypeCharSetAndSpacing arg++foreign import capi "fontconfig-wrap.h" fcFreeTypeCharSetAndSpacing ::+    FT_Face -> Ptr Int -> CString++-- | Constructs a pattern representing the 'id'th face in 'file'.+-- The number of faces in 'file' is returned in 'count'.+fontQuery :: FilePath -> Int -> (Int, Pattern)+fontQuery a b = fromMessage0 $ flip withCString' a $ \a' -> fcFreeTypeQuery a' b++foreign import capi "fontconfig-wrap.h" fcFreeTypeQuery ::+    CString -> Int -> Ptr Int -> CString++-- | Constructs patterns found in 'file', all patterns found in 'file' are added to 'set'.+-- The number of faces in 'file' is returned in 'count'.+-- The number of patterns added to 'set' is returned.+fontQueryAll :: FilePath -> (Int, Int, FontSet)+fontQueryAll a = fromMessage0 $ withCString' fcFreeTypeQueryAll a++foreign import capi "fontconfig-wrap.h" fcFreeTypeQueryAll ::+    CString -> Ptr Int -> CString++-- | Constructs a pattern representing 'face'. 'file' and 'id' are used solely+-- as data for pattern elements (FC_FILE, FC_INDEX and sometimes FC_FAMILY).+fontQueryFace :: FT_Face -> FilePath -> Int -> Pattern+fontQueryFace a b c = fromMessage0 $ flip withCString' b $ \b' -> fcFreeTypeQueryFace a b' $ fromEnum c++foreign import capi "fontconfig-wrap.h" fcFreeTypeQueryFace ::+    FT_Face -> CString -> Int -> Ptr Int -> CString++------+--- Transliterated from FcFt+--- https://codeberg.org/dnkl/fcft/+--- Untested+------++-- | A `FT_Face` queried from FontConfig with glyph-loading parameters.+data FTFC_Instance = Instance {+    fontName :: Maybe String,+    fontPath :: Maybe String,+    fontFace :: FT_Face,+    fontLoadFlags :: Int,+    fontAntialias :: Bool,+    fontEmbolden :: Bool,+    fontIsColor :: Bool,+    fontRenderFlags :: Int,+    fontRenderFlagsSubpixel :: Int,+    fontPixelSizeFixup :: Double,+    fontPixelFixupEstimated :: Bool,+    fontBGR :: Bool,+    fontLCDFilter :: FT_LcdFilter,+    fontFeats :: [String], -- Callers probably want to validate via harfbuzz+    fontMetrics :: FTFC_Metrics+}+-- | Results queried from FontConfig with caller-relevant properties,+-- notably relating to layout.+data FTFC_Metrics = Metrics {+    height :: Int,+    descent :: Int,+    ascent :: Int,+    maxAdvance :: (Int, Int), -- Width/height of font's widest glyph.+    metricsAntialias :: Bool,+    metricsSubpixel :: FTFC_Subpixel,+    metricsName :: Maybe String+}+-- | Defines subpixel order to use.+-- Note that this is *ignored* if antialiasing has been disabled.+data FTFC_Subpixel = SubpixelNone -- ^ From FontConfig.+    | SubpixelHorizontalRGB | SubpixelHorizontalBGR |+    SubpixelVerticalRGB | SubpixelVerticalBGR+    | SubpixelDefault -- ^ Disable subpixel antialiasing.++-- | Converts the results of a FontConfig query requesting a specific size+-- into a `FT_Face` & related properties.+-- Throw exceptions.+instantiatePattern :: FT_Library -> Pattern -> (Double, Double) -> IO FTFC_Instance+instantiatePattern ftlib pattern (req_pt_size, req_px_size) = do+    let dpi = fromMaybe 75 $ getValue "dpi" pattern :: Double++    ft_face <- case () of --getValue "ftface" pattern of+        -- ValueFTFace x -> return x+        _ -> ft_New_Face ftlib (fromJust $ getValue "file" pattern) -- is a mutex needed?+            (toEnum $ fromMaybe 0 $ getValue "index" pattern)++    ft_Set_Pixel_Sizes ft_face 0 $ toEnum $ fromEnum $+        fromMaybe req_px_size $ getValue "pixelsize" pattern+    let scalable = fromMaybe True $ getValue "scalable" pattern+    let outline = fromMaybe True $ getValue "outline" pattern+    (pixel_fixup, fixup_estimated) <- case getValue "pixelsizefixupfactor" pattern of+        Just (ValueDouble x) -> return (x, False)+        _ | scalable && not outline -> do+            let px_size = if req_px_size < 0 then req_pt_size * dpi / 72 else req_px_size+            ft_face' <- peek ft_face+            size' <- peek $ frSize ft_face'+            return (px_size / (fromIntegral $ smY_ppem $ srMetrics size'), True)+        _ -> return (1, False)++    let hinting = fromMaybe True $ getValue "hinting" pattern+    let antialias = fromMaybe True $ getValue "antialias" pattern+    let hintstyle = fromMaybe 1 $ getValue "hintstyle" pattern :: Int+    let rgba = fromMaybe 0 $ getValue "rgba" pattern :: Int+    let load_flags | not antialias && (not hinting || hintstyle == 0) =+                        ft_LOAD_NO_HINTING .|. ft_LOAD_MONOCHROME+                   | not antialias = ft_LOAD_MONOCHROME+                   | not hinting || hintstyle == 0 = ft_LOAD_NO_HINTING+                   | otherwise = ft_LOAD_DEFAULT+    let load_target | not antialias && hinting && hintstyle /= 0 = ft_LOAD_TARGET_MONO+                    | not antialias = ft_LOAD_TARGET_NORMAL+                    | not hinting || hintstyle == 0 = ft_LOAD_TARGET_NORMAL+                    | hintstyle == 1 = ft_LOAD_TARGET_LIGHT+                    | hintstyle == 2 = ft_LOAD_TARGET_NORMAL+                    | rgba `elem` [1, 2] = ft_LOAD_TARGET_LCD+                    | rgba `elem` [3, 4] = ft_LOAD_TARGET_LCD_V+                    | otherwise = ft_LOAD_TARGET_NORMAL++    --let embedded_bitmap = fromMaybe True $ getValue "embeddedbitmap" pattern+    --let load_flags1 | embedded_bitmap = load_flags .|. ft_LOAD_NO_BITMAP+    --                | otherwise = load_flags+    --let autohint = fromMaybe False $ getValue "autohint" pattern+    --let load_flags2 | autohint = load_flags .|. ft_LOAD_FORCE_AUTOHINT+    --                | otherwise = load_flags+    let render_flags_normal | not antialias = ft_RENDER_MODE_MONO+                            | otherwise = ft_RENDER_MODE_NORMAL+    let render_flags_subpixel | not antialias = ft_RENDER_MODE_MONO+                              | rgba `elem` [1, 2] = ft_RENDER_MODE_LCD+                              | rgba `elem` [3, 4] = ft_RENDER_MODE_LCD_V+                              | otherwise = ft_RENDER_MODE_NORMAL++    let lcdfilter :: Int+        lcdfilter = case fromMaybe 1 $ getValue "lcdfilter" pattern of+            3 -> 16+            x -> x+    case getValue "matrix" pattern of+        Just (ValueMatrix m) -> ft_Set_Transform ft_face (Just $ m22toFt m) Nothing+        _ -> return ()++    ft_face' <- peek ft_face+    size' <- peek $ frSize ft_face'+    let metrics' = srMetrics size'+    let c x = fromIntegral x / 64 * pixel_fixup+    return Instance {+        fontName = getValue "fullname" pattern,+        fontPath = getValue "file" pattern,+        fontFace = ft_face,+        fontLoadFlags = load_target .|. load_flags .|. ft_LOAD_COLOR,+        fontAntialias = antialias,+        fontEmbolden = fromMaybe False $ getValue "embolden" pattern,+        fontIsColor = fromMaybe False $ getValue "color" pattern,+        fontRenderFlags = render_flags_normal,+        fontRenderFlagsSubpixel = render_flags_subpixel,+        fontPixelSizeFixup = pixel_fixup,+        fontPixelFixupEstimated = fixup_estimated,+        fontBGR = rgba `elem` [2, 4],+        fontLCDFilter = toEnum lcdfilter,+        fontFeats = getValues "fontfeatures" pattern,+        fontMetrics = Metrics {+            height = fromEnum $ c $ smHeight metrics',+            descent = fromEnum $ c $ smDescender metrics',+            ascent = fromEnum $ c $ smAscender metrics',+            maxAdvance = (fromEnum $ c $ smMax_advance metrics',+                fromEnum $ c $ smHeight metrics'),+            metricsAntialias = antialias,+            metricsSubpixel = case rgba of+                _ | not antialias -> SubpixelNone+                1 -> SubpixelHorizontalRGB+                2 -> SubpixelHorizontalBGR+                3 -> SubpixelVerticalRGB+                4 -> SubpixelVerticalBGR+                _ -> SubpixelNone,+            metricsName = getValue "fullname" pattern+        }+      }++-- | Results from `glyphForIndex`.+data FTFC_Glyph a = Glyph {+    glyphFontName :: Maybe String,+    glyphImage :: a,+    glyphAdvance :: (Double, Double),+    glyphSubpixel :: FTFC_Subpixel,+    glyphMetrics :: FT_Glyph_Metrics+}++-- | Looks up a given glyph in a `FTFC_Instance` & its underlying `FT_Face`+-- Taking into account additional properties from FontConfig.+-- Runs a provided callback to render the glyph into a reusable datastructure.+-- The `FT_Bitmap` given to this callback must not be used outside it.+-- Throws exceptions.+glyphForIndex :: FTFC_Instance -> Word32 -> FTFC_Subpixel -> +    (FT_Bitmap -> IO a) -> IO (FTFC_Glyph a)+glyphForIndex font index subpixel cb = do+    ft_Load_Glyph (fontFace font) index (toEnum $ fontLoadFlags font)+    face' <- peek $ fontFace font+    size' <- peek $ frSize face'+    -- Formula from old FreeType function `FT_GlyphSlotEmbolden`.+    -- Approximate as fallback for fonts not using fontsets or variables axis.+    let strength = fromIntegral (frUnits_per_EM face')*smY_scale (srMetrics size')`div`24+    glyph' <- peek $ frGlyph face'++    glyph1' <- case gsrFormat glyph' of+        FT_GLYPH_FORMAT_OUTLINE | fontEmbolden font -> do+            outline <- withPtr (gsrOutline glyph') $ flip ft_Outline_Embolden strength+            return glyph' { gsrOutline = outline }+        _ -> return glyph'++    let render_flags = case subpixel of {+-- FT_GLYPH_FORMAT_SVG is not exposed by our language bindings,+-- Should be largely irrelevant now... Certain FreeType versions required this flag.+--        _ | FT_GLYPH_FORMAT_SVG <- gsrFormat glyph1' -> ft_RENDER_MODE_NORMAL;+        _ | not $ fontAntialias font -> fontRenderFlags font;+        SubpixelNone -> fontRenderFlags font;+        SubpixelHorizontalRGB -> ft_RENDER_MODE_LCD;+        SubpixelHorizontalBGR -> ft_RENDER_MODE_LCD;+        SubpixelVerticalRGB -> ft_RENDER_MODE_LCD_V;+        SubpixelVerticalBGR -> ft_RENDER_MODE_LCD_V;+        SubpixelDefault -> fontRenderFlagsSubpixel font}+    {-let bgr = case subpixel of+            _ | not $ fontAntialias font -> False+            SubpixelNone -> False+            SubpixelHorizontalRGB -> False+            SubpixelHorizontalBGR -> True+            SubpixelVerticalRGB -> False+            SubpixelVerticalBGR -> True+            SubpixelDefault -> fontBGR font-}++    can_set_lcd_filter <- isSuccess $ ft_Library_SetLcdFilter (gsrLibrary glyph1') 0+    -- FIXME: Do we need a mutex?+    let set_lcd_filter = ft_Library_SetLcdFilter (gsrLibrary glyph1') $ fontLCDFilter font+    case render_flags of {+        FT_RENDER_MODE_LCD | can_set_lcd_filter -> set_lcd_filter;+        FT_RENDER_MODE_LCD_V | can_set_lcd_filter -> set_lcd_filter;+        _ -> return ()}++    glyph2' <- case gsrFormat glyph1' of {+        FT_GLYPH_FORMAT_BITMAP -> return glyph1';+        _ -> withPtr glyph1' $ flip ft_Render_Glyph $ toEnum render_flags}+    -- If set_lcd_filter requires mutex, release it here.+    case gsrFormat glyph2' of {+        FT_GLYPH_FORMAT_BITMAP -> return ();+        _ -> throw $ FtError "glyphForIndex" 2+    }++    img <- cb $ gsrBitmap glyph2'+    return Glyph {+        glyphFontName = fontName font, glyphImage = img,+        glyphAdvance = (fromIntegral (vX $ gsrAdvance glyph2') / 64 *+            if fontPixelFixupEstimated font then fontPixelSizeFixup font else 1,+            fromIntegral (vY $ gsrAdvance glyph2') / 64 *+            if fontPixelFixupEstimated font then fontPixelSizeFixup font else 1),+        glyphSubpixel = subpixel,+        glyphMetrics = gsrMetrics glyph2'+    }++-- | Convience API around `glyphForIndex` to retrieve the image & metrics of the font's glyph.+bmpAndMetricsForIndex ::+    FTFC_Instance -> FTFC_Subpixel -> Word32 -> IO (FT_Bitmap, FT_Glyph_Metrics)+bmpAndMetricsForIndex inst subpixel index = do+    glyph <- glyphForIndex inst index subpixel pure+    return (glyphImage glyph, glyphMetrics glyph)++withPtr :: Storable a => a -> (Ptr a -> IO b) -> IO a+withPtr a cb = alloca $ \a' -> do+    poke a' a+    _ <- cb a'+    peek a'++isSuccess :: IO a -> IO Bool+isSuccess cb = do+    _ <- cb+    return True+  `catch` \(FtError _ _) -> return False++m22toFt :: M22 Double -> FT_Matrix+m22toFt (V2 (V2 xx xy) (V2 yx yy)) = FT_Matrix {+    mXx = c xx * 0x10000, mXy = c xy * 0x10000,+    mYx = c yx * 0x10000, mYy = c yy * 0x10000+  } where c = toEnum . fromEnum++-- Taken from FreeType language bindings,+-- but converted to constants rather than pattern synonyms.+ft_LOAD_DEFAULT, {-ft_LOAD_NO_SCALE,-} ft_LOAD_NO_HINTING, {-ft_LOAD_RENDER,+    ft_LOAD_NO_BITMAP, ft_LOAD_VERTICAL_LAYOUT, ft_LOAD_FORCE_AUTOHINT,+    ft_LOAD_CROP_BITMAP, ft_LOAD_PEDANTIC, ft_LOAD_IGNORE_GLOBAL_ADVANCE_WIDTH,+    ft_LOAD_NO_RECURSE, ft_LOAD_IGNORE_TRANSFORM,-} ft_LOAD_MONOCHROME,+    {-ft_LOAD_LINEAR_DESIGN, ft_LOAD_NO_AUTOHINT,-} ft_LOAD_COLOR{-,+    ft_LOAD_COMPUTE_METRICS, ft_LOAD_BITMAP_METRICS_ONLY-} :: Int+ft_LOAD_DEFAULT                     = 0+--ft_LOAD_NO_SCALE                    = 1+ft_LOAD_NO_HINTING                  = 2+--ft_LOAD_RENDER                      = 4+--ft_LOAD_NO_BITMAP                   = 8+--ft_LOAD_VERTICAL_LAYOUT             = 16+--ft_LOAD_FORCE_AUTOHINT              = 32+--ft_LOAD_CROP_BITMAP                 = 64+--ft_LOAD_PEDANTIC                    = 128+--ft_LOAD_IGNORE_GLOBAL_ADVANCE_WIDTH = 512+--ft_LOAD_NO_RECURSE                  = 1024+--ft_LOAD_IGNORE_TRANSFORM            = 2048+ft_LOAD_MONOCHROME                  = 4096+--ft_LOAD_LINEAR_DESIGN               = 8192+--ft_LOAD_NO_AUTOHINT                 = 32768+ft_LOAD_COLOR                       = 1048576+--ft_LOAD_COMPUTE_METRICS             = 2097152+--ft_LOAD_BITMAP_METRICS_ONLY         = 4194304++ft_LOAD_TARGET_NORMAL, ft_LOAD_TARGET_LIGHT, ft_LOAD_TARGET_MONO,+    ft_LOAD_TARGET_LCD, ft_LOAD_TARGET_LCD_V :: Int+ft_LOAD_TARGET_NORMAL = 0+ft_LOAD_TARGET_LIGHT  = 65536+ft_LOAD_TARGET_MONO   = 131072+ft_LOAD_TARGET_LCD    = 196608+ft_LOAD_TARGET_LCD_V  = 262144++ft_RENDER_MODE_NORMAL, {-ft_RENDER_MODE_LIGHT,-} ft_RENDER_MODE_MONO,+    ft_RENDER_MODE_LCD, ft_RENDER_MODE_LCD_V :: Int+ft_RENDER_MODE_NORMAL = 0+--ft_RENDER_MODE_LIGHT  = 1+ft_RENDER_MODE_MONO   = 2+ft_RENDER_MODE_LCD    = 3+ft_RENDER_MODE_LCD_V  = 4
+ lib/Graphics/Text/Font/Choose.hs view
@@ -0,0 +1,30 @@+-- | Query installed fonts from FontConfig.+module Graphics.Text.Font.Choose(+        module Graphics.Text.Font.Choose.Config.Accessors, Config', fini, version,+        initLoadConfig, initLoadConfigAndFonts, initFonts, reinit, bringUptoDate,+        CharSet, ord, chr, parseCharSet, CharSet'(..), validCharSet',+        module Graphics.Text.Font.Choose.FontSet,+        LangSet, LangSet'(..), LangComparison(..), validLangSet, validLangSet',+        cmp, cmp', has, defaultLangs, langs, normalize, langCharSet,+        module Graphics.Text.Font.Choose.ObjectSet,+        Pattern, Pattern'(..), Binding(..), validPattern, validPattern',+        setValue, setValues, getValue, getValues, equalSubset, defaultSubstitute,+        nameParse, nameUnparse, nameFormat,+        module Graphics.Text.Font.Choose.Range,+        FcException(..), StrSet(..), validStrSet,+        module Graphics.Text.Font.Choose.Value,+        module Graphics.Text.Font.Choose.Weight+    ) where++import Graphics.Text.Font.Choose.Config.Accessors+import Graphics.Text.Font.Choose.Config+import Graphics.Text.Font.Choose.CharSet+import Graphics.Text.Font.Choose.FontSet+import Graphics.Text.Font.Choose.LangSet+import Graphics.Text.Font.Choose.ObjectSet+import Graphics.Text.Font.Choose.Pattern+import Graphics.Text.Font.Choose.Range+import Graphics.Text.Font.Choose.Result+import Graphics.Text.Font.Choose.StrSet+import Graphics.Text.Font.Choose.Value+import Graphics.Text.Font.Choose.Weight
+ lib/Graphics/Text/Font/Choose/CharSet.hs view
@@ -0,0 +1,70 @@+-- | Process sets of unicode characters, possibly parsed from CSS.+module Graphics.Text.Font.Choose.CharSet(+        CharSet, ord, chr, module IntSet, parseCharSet, CharSet'(..), validCharSet'+    ) where++import Data.IntSet as IntSet++import Data.Char (isHexDigit, isSpace, ord, chr)+import Numeric (readHex)++import Data.MessagePack (MessagePack(..), Object(..))+import Test.QuickCheck (Arbitrary(..))++-- | An FcCharSet is a set of Unicode characters.+type CharSet = IntSet++parseChar :: String -> Int+parseChar str | ((x, _):_) <- readHex str = toEnum x+    | otherwise = 0+replaceWild :: Char -> String -> String+replaceWild ch ('?':rest) = ch:replaceWild ch rest+replaceWild ch (c:cs) = c:replaceWild ch cs+replaceWild _ "" = ""+parseWild :: Char -> String -> Int+parseWild ch str = parseChar $ replaceWild ch str+-- | Utility for parsing "unicode-range" @font-face property.+parseCharSet :: String -> Maybe CharSet+parseCharSet (c:rest) | isSpace c = parseCharSet rest -- Irrelevant in Stylist integration.+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 $ union set $ IntSet.fromList [parseChar start..parseChar end]+    | (codepoint@(_:_), rest) <- span isHexDigit cs, Just set <- parseCharSet' rest =+        Just $ flip IntSet.insert set $ parseChar codepoint+    | (codepoint@(_:_), rest) <- span (\c -> isHexDigit c || c == '?') cs,+        Just set <- parseCharSet' rest =+            Just $ IntSet.union set $ IntSet.fromList [+                parseWild '0' codepoint..parseWild 'f' codepoint]+parseCharSet _ = Nothing+parseCharSet' :: String -> Maybe CharSet+parseCharSet' (',':rest) = parseCharSet rest+parseCharSet' "" = Just IntSet.empty+parseCharSet' _ = Nothing++-- NOTE: Serial already provides IntSet a CBOR codec, but its quite naive.+-- I suspect that CharSets are typically quite dense,+-- So a diff-compression pass should play well with ++diffCompress :: Int -> [Int] -> [Int]+diffCompress prev (x:xs) = x - prev:diffCompress x xs+diffCompress _ [] = []+diffDecompress :: Int -> [Int] -> [Int]+diffDecompress prev (x:xs) = let y = prev + x in y:diffDecompress y xs+diffDecompress _ [] = []++-- | Wrapper around `CharSet` which can implement typeclasses.+newtype CharSet' = CharSet' { unCharSet :: CharSet } deriving (Eq, Read, Show)+instance MessagePack CharSet' where+    toObject = toObject . diffCompress 0 . IntSet.toAscList . unCharSet+    fromObject (ObjectExt 0x63 _) = Just $ CharSet' IntSet.empty+    fromObject msg =+        CharSet' <$> IntSet.fromAscList <$> diffDecompress 0 <$> fromObject msg+instance Arbitrary CharSet' where+    arbitrary = CharSet' <$> IntSet.fromList <$> Prelude.map (succ . abs) <$> arbitrary++-- | Can this charset be processed by FontConfig?+validCharSet' :: CharSet' -> Bool+validCharSet' (CharSet' self) =+    not (IntSet.null self) && all (> 0) (IntSet.toList self)
+ lib/Graphics/Text/Font/Choose/Config.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE CApiFFI #-}+-- | Load system fonts configuration.+module Graphics.Text.Font.Choose.Config(Config, fini, version,+        initLoadConfig, initLoadConfigAndFonts, initFonts, reinit, bringUptoDate,+        -- For the sake of Graphics.Font.Choose.Config.Accessors+        Config', fcConfigDestroy) where++import Foreign.Ptr (Ptr, FunPtr)+import Foreign.ForeignPtr (ForeignPtr, newForeignPtr)++import Graphics.Text.Font.Choose.Result (throwBool, throwNull)++-- | Internal placeholder underlying `Config`.+data Config'+-- | holds the internal representation of a configuration.+type Config = ForeignPtr Config'+++-- | Loads the default configuration file and returns the resulting configuration. Does not load any font information.+initLoadConfig :: IO Config+initLoadConfig = newForeignPtr fcConfigDestroy =<< throwNull =<< fcInitLoadConfig -- FIXME: What's proper memory-management here?++-- | Loads the default configuration file and builds information about the available fonts. Returns the resulting configuration.+initLoadConfigAndFonts :: IO Config+initLoadConfigAndFonts = newForeignPtr fcConfigDestroy =<< throwNull =<< fcInitLoadConfigAndFonts -- FIXME: What's proper memory-management here?++-- | 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 True.+initFonts :: IO ()+initFonts = throwBool =<< fcInit+-- | Closes FontConfig's database connection.+foreign import capi "fontconfig/fontconfig.h FcFini" fini :: IO ()++-- | Returns the version number of the library.+foreign import capi "fontconfig/fontconfig.h FcGetVersion" version :: Int++-- | 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.+reinit :: IO ()+reinit = throwBool =<< fcInitReinitialize++-- | 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 `reinit`). Otherwise returns True.+bringUptoDate :: IO ()+bringUptoDate = throwBool =<< fcInitBringUptoDate++foreign import capi "fontconfig/fontconfig.h FcInitLoadConfig" fcInitLoadConfig :: IO (Ptr Config')+foreign import capi "fontconfig/fontconfig.h FcInitLoadConfigAndFonts" fcInitLoadConfigAndFonts :: IO (Ptr Config')+foreign import capi "fontconfig/fontconfig.h FcInit" fcInit :: IO Bool+-- | Internal ForeignPtr destructor for `Config`.+foreign import capi "fontconfig/fontconfig.h &FcConfigDestroy" fcConfigDestroy :: FunPtr (Ptr Config' -> IO ())++foreign import capi "fontconfig/fontconfig.h FcInitReinitialize" fcInitReinitialize :: IO Bool+foreign import capi "fontconfig/fontconfig.h FcInitBringUptoDate" fcInitBringUptoDate :: IO Bool
+ lib/Graphics/Text/Font/Choose/Config/Accessors.hs view
@@ -0,0 +1,270 @@+{-# LANGUAGE CApiFFI #-}+-- | APIs for retrieving configuration+-- This is seperate from Graphics.Text.Font.Choose.Config to avoid cyclic dependencies.+module Graphics.Text.Font.Choose.Config.Accessors(+        configCreate, setCurrent, current, current', uptodate, home, enableHome, buildFonts,+        configDirs, fontDirs, configFiles, cacheDirs, fonts, rescanInterval,+        setRescanInterval, appFontAddFile, appFontAddDir, appFontClear, substitute,+        fontMatch, fontSort, fontRenderPrepare, fontList, filename, parseAndLoad,+        parseAndLoadFromMemory, sysroot, setSysroot, SetName(..), MatchKind(..)+    ) where++import Graphics.Text.Font.Choose.Config+import Graphics.Text.Font.Choose.FontSet+import Graphics.Text.Font.Choose.Pattern+import Graphics.Text.Font.Choose.CharSet+import Graphics.Text.Font.Choose.ObjectSet++import Foreign.Ptr (Ptr, nullPtr)+import Foreign.ForeignPtr (newForeignPtr, withForeignPtr)+import Foreign.C.String (CString, withCString, peekCString)+--import Foreign.C.ConstPtr (ConstPtr)+--import Foreign.C.Types (CChar)++import Graphics.Text.Font.Choose.Result (throwBool, throwNull)+import Graphics.Text.Font.Choose.Internal.FFI (peekCString', fromMessageIO0,+                withMessage, withForeignPtr', fromMessage0, fromMessage)++import System.IO.Unsafe (unsafePerformIO) -- For current'++-- | Creates an empty configuration.+configCreate :: IO Config+configCreate = newForeignPtr fcConfigDestroy =<< throwNull =<< fcConfigCreate+foreign import capi "fontconfig/fontconfig.h FcConfigCreate" fcConfigCreate :: IO (Ptr Config')++-- | Sets the current default configuration to config. Implicitly calls FcConfigBuildFonts+-- if necessary, and FcConfigReference() to inrease the reference count in config since 2.12.0.+setCurrent :: Config -> IO ()+setCurrent conf = throwBool =<< withForeignPtr conf fcConfigSetCurrent+foreign import capi "fontconfig/fontconfig.h FcConfigSetCurrent" fcConfigSetCurrent :: Ptr Config' -> IO Bool++-- | Returns the current default configuration, legacy impure function!+current :: IO Config+current = newForeignPtr fcConfigDestroy =<< throwNull =<< fcConfigReference nullPtr+foreign import capi "fontconfig/fontconfig.h FcConfigReference" fcConfigReference :: Ptr Config' -> IO (Ptr Config')++-- | Returns the current default configuration.+-- WARNING: Might not behave correctly around calls to `setCurrent`,+-- but given how many APIs expect a config this makes pure code easier to write.+{-# NOINLINE current' #-} -- To be double-safe.+current' :: Config+current' = unsafePerformIO current -- If I want to initialize a ForeignPtr, must unfortunately use impure code.++-- | Checks all of the files related to config and returns whether any of them has+-- been modified since the configuration was created.+uptodate :: Config -> IO Bool+uptodate conf = withForeignPtr conf fcConfigUptoDate+foreign import capi "fontconfig/fontconfig.h FcConfigUptoDate" fcConfigUptoDate :: Ptr Config' -> IO Bool++-- | Return the current user's home directory, if it is available & if using it is enabled.+home :: String+home = peekCString' fcConfigHome+foreign import capi "fontconfig/fontconfig.h FcConfigHome" fcConfigHome :: CString++-- | If given True, then Fontconfig will use various files which are specified+-- relative to the user's home directory (using the ~ notation in the configuration).+-- When its False, then all use of the home directory in these contexts will be disabled.+-- The previous setting of the value is returned.+foreign import capi "fontconfig/fontconfig.h FcConfigEnableHome" enableHome :: Bool -> IO Bool++-- | Builds the set of available fonts for the given configuration.+-- Note that any changes to the configuration after this call+-- (through parseAndLoad or parseAndLoadFromMemory) have indeterminate effects.+-- (On the other hand, application fonts can still be modified through+-- appFontAddFile, appFontAddDir and appFontClear).+buildFonts :: Config -> IO ()+buildFonts conf = throwBool =<< withForeignPtr conf fcConfigBuildFonts+foreign import capi "fontconfig/fontconfig.h FcConfigBuildFonts" fcConfigBuildFonts :: Ptr Config' -> IO Bool++-- | Returns the list of font directories specified in the configuration files.+-- Does not include any subdirectories.+configDirs :: Config -> IO [String]+configDirs conf =+    fromMessageIO0 $ \len -> withForeignPtr conf $ \conf' -> fcConfigGetConfigDirs conf' len+foreign import capi "fontconfig-wrap.h" fcConfigGetConfigDirs :: Ptr Config' -> Ptr Int -> IO CString++-- | Returns the list of font directories. This includes the configured font directories+-- along with any directories below those in the filesystem.+fontDirs :: Config -> IO [String]+fontDirs conf =+    fromMessageIO0 $ \len -> withForeignPtr conf $ \conf' -> fcConfigGetFontDirs conf' len+foreign import capi "fontconfig-wrap.h" fcConfigGetFontDirs :: Ptr Config' -> Ptr Int -> IO CString++-- | Returns the list of known configuration files used to generate given config.+configFiles :: Config -> IO [String]+configFiles conf =+    fromMessageIO0 $ \len -> withForeignPtr conf $ \conf' -> fcConfigGetConfigFiles conf' len+foreign import capi "fontconfig-wrap.h" fcConfigGetConfigFiles :: Ptr Config' -> Ptr Int -> IO CString++-- | returns a string list containing all of the directories that fontconfig will+-- search when attempting to load a cache file for a font directory.+cacheDirs :: Config -> IO [String]+cacheDirs conf =+    fromMessageIO0 $ \len -> withForeignPtr conf $ \conf' -> fcConfigGetCacheDirs conf' len+foreign import capi "fontconfig-wrap.h" fcConfigGetCacheDirs :: Ptr Config' -> Ptr Int -> IO CString++-- | Which set of fonts to retrieve.+data SetName = System -- ^ Fonts installed into the OS.+    | App -- ^ Fonts provided by this process.+    deriving (Read, Show, Eq, Enum)+-- | Returns one of the two sets of fonts from the configuration as specified by set.+fonts :: Config -> SetName -> IO FontSet+fonts conf setname =+    fromMessageIO0 $ \len -> withForeignPtr conf $ \conf' -> fcConfigGetFonts conf' (setname == System) len+foreign import capi "fontconfig-wrap.h" fcConfigGetFonts :: Ptr Config' -> Bool -> Ptr Int -> IO CString++-- | 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.+rescanInterval :: Config -> IO Int+rescanInterval = flip withForeignPtr fcConfigGetRescanInterval+foreign import capi "fontconfig/fontconfig.h FcConfigGetRescanInterval" fcConfigGetRescanInterval ::+        Ptr Config' -> IO Int++-- | Sets the rescan interval. An interval setting of zero disables automatic checks.+setRescanInterval :: Config -> Int -> IO ()+setRescanInterval conf period =+    throwBool =<< withForeignPtr conf (flip fcConfigSetRescanInterval period)+foreign import capi "fontconfig/fontconfig.h FcConfigSetRescanInterval" fcConfigSetRescanInterval ::+        Ptr Config' -> Int -> IO Bool++-- | Adds an application-specific font to the configuration.+appFontAddFile :: Config -> FilePath -> IO ()+appFontAddFile conf file = throwBool =<< withForeignPtr conf (\conf' ->+        withCString file $ \file' -> fcConfigAppFontAddFile conf' file')+foreign import capi "fontconfig/fontconfig.h FcConfigAppFontAddFile" fcConfigAppFontAddFile ::+        Ptr Config' -> CString -> IO Bool++-- | Scans the specified directory for fonts, adding each one found to the application-specific set of fonts.+appFontAddDir :: Config -> FilePath -> IO ()+appFontAddDir conf file = throwBool =<< withForeignPtr conf (\conf' ->+        withCString file $ \file' -> fcConfigAppFontAddDir conf' file')+foreign import capi "fontconfig/fontconfig.h FcConfigAppFontAddDir" fcConfigAppFontAddDir ::+        Ptr Config' -> CString -> IO Bool++-- | Clears the set of application-specific fonts.+appFontClear :: Config -> IO ()+appFontClear = flip withForeignPtr fcConfigAppFontClear+foreign import capi "fontconfig/fontconfig.h FcConfigAppFontClear" fcConfigAppFontClear ::+        Ptr Config' -> IO ()+++-- | Which pattern modifications to apply during `substituteWithPat`.+data MatchKind = MatchPattern -- ^ Applies pattern operations.+    | MatchFont -- ^ Applies font operations.+    deriving (Read, Show, Eq, Enum)+-- | Performs the sequence of pattern modification operations tagged by `kind`.+-- If kind is MatchPattern then those tagged as pattern operations are applied,+-- else if kind is MatchFont those tagged as font operations are applied+-- & p_pat is used for &lt;test&gt; elements with target=pattern.+substitute :: Config -> Pattern -> Maybe Pattern -> MatchKind -> Pattern+substitute conf p (Just p_pat) kind =+    fromMessage0 $ flip withForeignPtr' conf $ \conf' -> flip withMessage [p, p_pat] $ \msg len -> +        fcConfigSubstituteWithPat conf' msg len (kind == MatchFont)+substitute conf p Nothing kind =+    fromMessage0 $ flip withForeignPtr' conf $ \conf' -> flip withMessage [p] $ \msg len ->+        fcConfigSubstituteWithPat conf' msg len (kind == MatchFont)+foreign import capi "fontconfig-wrap.h" fcConfigSubstituteWithPat ::+    Ptr Config' -> CString -> Int -> Bool -> Ptr Int -> CString++-- | Finds the font in sets most closely matching pattern and returns the result+-- of fontRenderPrepare for that font and the provided pattern.+fontMatch :: Config -> Pattern -> Maybe Pattern+fontMatch conf pat = fromMessage $ flip withMessage pat $ withForeignPtr' fcFontMatch conf+foreign import capi "fontconfig-wrap.h" fcFontMatch :: Ptr Config' -> CString -> Int -> Ptr Int -> CString++-- | Returns the list of fonts sorted by closeness to p.+-- If trim is FcTrue, 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.+--+-- The returned FcFontSet references FcPattern structures which may be shared by the+-- return value from multiple FcFontSort calls, applications must not modify these patterns.+fontSort :: Config -> Pattern -> Bool -> Maybe (FontSet, CharSet')+fontSort conf pat trim = fromMessage $ (flip withMessage pat $ withForeignPtr' fcFontSort conf) trim+foreign import capi "fontconfig-wrap.h" fcFontSort ::+    Ptr Config' -> CString -> Int -> Bool -> Ptr Int -> CString++-- | 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 FcConfigSubstituteWithPat with kind FcMatchFont and then returned.+fontRenderPrepare :: Config -> Pattern -> Pattern -> Pattern+fontRenderPrepare conf pat font = fromMessage0 $ flip withMessage [pat, font] $+        withForeignPtr' fcFontRenderPrepare conf+foreign import capi "fontconfig-wrap.h" fcFontRenderPrepare ::+    Ptr Config' -> CString -> Int -> Ptr Int -> CString++-- | Selects fonts matching p, creates patterns from those fonts containing only+-- the given objects and returns the set of unique such patterns.+fontList :: Config -> Pattern -> ObjectSet -> FontSet+fontList conf pat os = fromMessage0 $ flip withMessage (pat, os) $ withForeignPtr' fcFontList conf+foreign import capi "fontconfig-wrap.h" fcFontList :: Ptr Config' -> CString -> Int -> Ptr Int -> CString++-- | Given the specified external entity name, return the associated filename. This provides+-- applications a way to convert various configuration file references into filename form.+--+-- An empty name indicates that the default configuration file should be used;+-- which file this references can be overridden with the FONTCONFIG_FILE environment variable.+-- Next, if the name starts with ~, it refers to a file in the current users home directory.+-- Otherwise if the name doesn't start with '/', it refers to a file in the default config dir;+-- the built-in default directory can be overridden with the FONTCONFIG_PATH environment variable.+--+-- The result of this function is affected by the FONTCONFIG_SYSROOT environment variable+-- or equivalent functionality.+filename :: Config -> FilePath -> IO FilePath+filename conf path =+    peekCString =<< withForeignPtr conf (\_ -> withCString path $ fcConfigGetFilename)+foreign import capi "fontconfig/fontconfig.h FcConfigFilename" fcConfigGetFilename ::+    CString -> IO CString -- FIXME: Recent docs say it's "Get" now...++-- | Walks the configuration in 'path' and constructs the internal representation in 'conf'.+-- Any include files referenced from within 'path' will be loaded and parsed.+-- If 'complain' is False, no warning will be displayed if 'path' does not exist.+-- Error and warning messages will be output to stderr.+-- Throws an exception if some error occurred while loading the file, either a parse error,+-- semantic error or allocation failure. After all configuration files or strings have been loaded,+-- with FcConfigParseAndLoad inclusive-or FcConfigParseAndLoadFromMemory,+-- call FcConfigBuildFonts to build the font database.+parseAndLoad :: Config -> FilePath -> Bool -> IO ()+parseAndLoad conf path complain =+    throwBool =<< withForeignPtr conf (\conf' -> withCString path $ \path' ->+        fcConfigParseAndLoad conf' path' complain)+foreign import capi "fontconfig/fontconfig.h FcConfigParseAndLoad" fcConfigParseAndLoad ::+    Ptr Config' -> CString -> Bool -> IO Bool+-- | Walks the configuration in 'buf' and constructs the internal representation in 'conf'.+-- Any includes files referenced from within 'buf' 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.+-- Throws an exception if fsome error occurred while loading the file, either a parse error,+-- semantic error or allocation failure. After all configuration files or strings have been loaded,+-- with FcConfigParseAndLoad inclusive-or FcConfigParseAndLoadFromMemory,+-- call FcConfigBuildFonts to build the font database.+parseAndLoadFromMemory :: Config -> FilePath -> Bool -> IO ()+parseAndLoadFromMemory conf buf complain =+    throwBool =<< withForeignPtr conf (\conf' -> withCString buf $ \buf' ->+        fcConfigParseAndLoadFromMemory conf' buf' complain)+foreign import capi "fontconfig/fontconfig.h FcConfigParseAndLoadFromMemory"+    fcConfigParseAndLoadFromMemory :: Ptr Config' -> CString -> Bool -> IO Bool++-- | Obtains the system root directory in 'conf' if available.+-- All files (including file properties in patterns) obtained from this 'conf'+-- are relative to this system root directory.+sysroot :: Config -> IO String+sysroot conf = peekCString =<< withForeignPtr conf fcConfigGetSysRoot+-- FIXME: Upgrade GHC so I can use const pointers!+foreign import ccall "fontconfig/fontconfig.h FcConfigGetSysRoot" fcConfigGetSysRoot ::+    Ptr Config' -> IO CString++-- | Set 'root' as the system root directory. All file paths used or created with this 'conf'+-- (including file properties in patterns) will be considered or made relative to this 'root'.+-- 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 'FcConfigGetSysRoot'+-- is used to resolve file paths. When setting this on the current config this causes+-- changing current config (calls FcConfigSetCurrent()).+setSysroot :: Config -> String -> IO ()+setSysroot conf root =+    withForeignPtr conf $ \conf' -> withCString root $ fcConfigSetSysRoot conf'+foreign import capi "fontconfig/fontconfig.h FcConfigSetSysRoot" fcConfigSetSysRoot ::+    Ptr Config' -> CString -> IO ()++-- TODO (maybe): FcConfigFileInfoIterInit, FcConfigFileInfoIterNext, & FcConfigFileInfoIterGet
+ lib/Graphics/Text/Font/Choose/FontSet.hs view
@@ -0,0 +1,162 @@+{-# LANGUAGE CApiFFI, OverloadedStrings #-}+-- | A set of fonts to query, or resulting from a query.+module Graphics.Text.Font.Choose.FontSet(+        FontSet, validFontSet, fontSetList, fontSetMatch, fontSetSort, FontFaceParser(..), emptyParser+    ) where++import Graphics.Text.Font.Choose.Pattern hiding (map)+import Graphics.Text.Font.Choose.Config+import Graphics.Text.Font.Choose.ObjectSet+import Graphics.Text.Font.Choose.CharSet as CS hiding (map)+import Graphics.Text.Font.Choose.Internal.FFI++import Foreign.C.String (CString)+import Foreign.Ptr (Ptr)+import Data.MessagePack (MessagePack)++import Stylist (StyleSheet(..))+import Stylist.Parse (parseProperties)+import Data.CSS.Syntax.Tokens (Token(..), serialize)+import Data.Text (Text, unpack)+import qualified Data.Text as Txt+import qualified Data.Map as M+import Data.List (intercalate)++import Graphics.Text.Font.Choose.Range (iRange)+import Graphics.Text.Font.Choose.Value (ToValue(..), Value)++-- | holds a list of patterns; these are used to return the results of listing available fonts.+type FontSet = [Pattern]++-- | Can the FontSet be processed by FontConfig?+validFontSet :: FontSet -> Bool+validFontSet = all validPattern++-- | holds a list of patterns; these are used to return the results of listing available fonts.+-- If the fontset is invalid, +fontSetList :: Config -> [FontSet] -> Pattern -> ObjectSet -> FontSet+fontSetList a b c d | all validFontSet b =+    fromMessage0 $ arg d $ arg c $ arg b $ withForeignPtr' fcFontSetList a+  | otherwise = []++foreign import capi "fontconfig-wrap.h" fcFontSetList ::+        Ptr Config' -> CString -> Int -> CString -> Int -> CString -> Int ->+        Ptr Int -> CString++-- | Finds the font in sets most closely matching pattern and returns the result+-- of `fontRenderPrepare` for that font and the provided pattern.+fontSetMatch :: Config -> [FontSet] -> Pattern -> Maybe FontSet+fontSetMatch a b c | all validFontSet b && validPattern c =+        fromMessage $ arg c $ arg b $ withForeignPtr' fcFontSetMatch a+    | otherwise = Nothing++foreign import capi "fontconfig-wrap.h" fcFontSetMatch ::+        Ptr Config' -> CString -> Int -> CString -> Int -> Ptr Int -> CString++-- | Returns the list of fonts from sets sorted by closeness to pattern.+-- If True is passed, 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 alongside the fontset.++-- Returns an empty CharSet & Nothing upon error, or invalid inputs.+fontSetSort :: Config -> [FontSet] -> Pattern -> Bool -> (Maybe FontSet, CharSet')+fontSetSort a b c d | all validFontSet b && validPattern c =+        fromMessage0 $ flip withForeignPtr' a $ \a' ->+            arg b $ \b' x -> arg c $ \c' y -> fcFontSetSort a' b' x c' y d+    | otherwise = (Nothing, CharSet' CS.empty)++foreign import capi "fontconfig-wrap.h" fcFontSetSort ::+        Ptr Config' -> CString -> Int -> CString -> Int -> Bool -> Ptr Int -> CString++------+--- Utilities+------+-- | Variation of `withMessage` that's proving to be more concise.+arg :: MessagePack a => a -> (CString -> Int -> b) -> b+arg = flip withMessage++------+--- CSS Bindings+------++-- | `StyleSheet` wrapper to parse @font-face rules.+data FontFaceParser a = FontFaceParser { cssFonts :: FontSet, cssInner :: a}++emptyParser :: a -> FontFaceParser a+emptyParser = FontFaceParser []++parseFontFaceSrc :: [Token] -> [String]+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 (Function "url":String link:RightParen:toks) =+    parseFontFaceSrc (Url link:toks) -- TODO: Why's this needed?++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 _ = [""]++v :: ToValue x => x -> Value+v = toValue++properties2font :: [(Text, [Token])] -> Pattern+properties2font (("font-family", [String font]):props) =+    M.insert "family" [(Strong, v $ unpack font)] $ properties2font props+properties2font (("font-family", [Ident font]):props) =+    M.insert "family" [(Strong, v $ unpack font)] $ properties2font props++properties2font (("font-stretch", [tok]):props) | Just x <- parseFontStretch tok =+    M.insert "width" [(Strong, v x)] $ properties2font props+properties2font (("font-stretch", [start, end]):props)+    | Just x <- parseFontStretch start, Just y <- parseFontStretch end =+        M.insert "width" [(Strong, v $ iRange x y)] $ properties2font props++properties2font (("font-weight", [tok]):props) | Just x <- parseFontWeight tok =+    M.insert "weight" [(Strong, v x)] $ properties2font props+properties2font (("font-weight", [start, end]):props)+    | Just x <- parseFontStretch start, Just y <- parseFontStretch end =+        M.insert "weight" [(Strong, v $ iRange x y)] $ properties2font props++properties2font (("font-feature-settings", toks):props)+    | (features, True, []) <- parseFontFeatures toks =+        M.insert "fontfeatures" [(Strong, v $ intercalate "," $ map fst features)] $+            properties2font props++properties2font (("font-variation-settings", toks):props)+    | (_, True, []) <- parseFontVars toks =+        M.insert "variable" [(Strong, v $ True)] $ properties2font props++properties2font (("unicode-range", toks):props)+    | Just chars <- parseCharSet $ unpack $ Txt.replace "/**/" "" $ serialize toks =+        M.insert "charset" [(Strong, v $ CharSet' chars)] $ properties2font props++-- Ignoring metadata & trusting in FreeType's broad support for fonts.+properties2font (("src", toks):props)+    | fonts@(_:_) <- parseFontFaceSrc toks, "" `notElem` fonts =+        M.insert "web-src" [(Strong, v f) | f <- fonts] $ properties2font props++properties2font (_:props) = properties2font props+properties2font [] = M.empty++instance StyleSheet a => StyleSheet (FontFaceParser a) where+    setPriorities prio (FontFaceParser x self) = FontFaceParser x $ setPriorities prio 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)
+ lib/Graphics/Text/Font/Choose/Internal/FFI.hs view
@@ -0,0 +1,88 @@+-- | Utilities for writing language bindings transferring complex parameters.+-- Encoding & decoding parameters via MessagePack.+module Graphics.Text.Font.Choose.Internal.FFI(+        unpackWithErr, withMessageIO, withMessage, fromMessage, fromMessage0,+        fromMessageIO0, withCString', peekCString', withForeignPtr'+    ) where++import Data.MessagePack (MessagePack(fromObject), pack, unpack, Object(ObjectStr))+import Foreign.C.String (CString, withCString, peekCString)+import Foreign.Ptr (Ptr, nullPtr)+import Foreign.ForeignPtr (ForeignPtr, withForeignPtr)+import Foreign.Storable (Storable(..))+import Foreign.Marshal.Alloc (alloca, free)+import Data.Tuple (swap)+import Graphics.Text.Font.Choose.Result (throwNull, FcException)+import Data.Maybe (fromJust)+import Text.Read (readMaybe)+import Control.Exception (throw)++import Data.ByteString.Unsafe (unsafeUseAsCStringLen, unsafePackMallocCStringLen)+import Data.ByteString.Lazy (toStrict, fromStrict, ByteString)+import qualified Data.Text as Txt+import System.IO.Unsafe (unsafePerformIO)++-- | Decode a MessagePack packet whilst throwing textually-specified exceptions.+unpackWithErr :: MessagePack a => ByteString -> Maybe a+unpackWithErr bs = case unpack bs of+    Just (ObjectStr err) |+        Just x <- (readMaybe $ Txt.unpack err :: Maybe FcException) -> throw x+    Just x -> fromObject x+    Nothing -> Nothing++-- | Encode data via MessagePack to pass to an impure C function.+withMessageIO :: MessagePack a => (CString -> Int -> IO b) -> a -> IO b+withMessageIO cb a = unsafeUseAsCStringLen (toStrict $ pack a) (uncurry cb)++-- | Encode data via MessagePack to pass to a pure C function.+withMessage :: MessagePack a => (CString -> Int -> b) -> a -> b+withMessage inner arg = unsafePerformIO $ withMessageIO (\x -> return . inner x) arg++-- | Decode data via MessagePack returned from a pure C function.+fromMessage :: MessagePack a => (Ptr Int -> CString) -> Maybe a+fromMessage inner = unpackWithErr $ fromStrict $ unsafePerformIO $ do+    unsafePackMallocCStringLen . swap =<< withPtr (throwNull . inner)++-- | Decode data via MessagePack returned from a pure C function,+-- throwing exceptions upon failed decodes.+fromMessage0 :: MessagePack a => (Ptr Int -> CString) -> a+fromMessage0 = fromJust . fromMessage++-- | Decode data via MessagePack returned from an impure C function.+fromMessageIO :: MessagePack a => (Ptr Int -> IO CString) -> IO (Maybe a)+fromMessageIO inner = do+    (a, b) <- withPtr $ \ptr -> do+        throwNull =<< inner ptr+    bs <- unsafePackMallocCStringLen (b, a)+    return $ unpackWithErr $ fromStrict bs++-- | Decode data via MessagePack returned from an impure C function,+-- throwing exceptions upon failed decodes.+fromMessageIO0 :: MessagePack a => (Ptr Int -> IO CString) -> IO a+fromMessageIO0 inner = fromJust <$> fromMessageIO inner++-- | Pass a string to a pure C function.+withCString' :: (CString -> a) -> String -> a+withCString' inner = unsafePerformIO . flip withCString (return . inner)++-- | Return a string from a pure C function+peekCString' :: CString -> String+peekCString' ptr | ptr /= nullPtr = unsafePerformIO $ do+    ret <- peekCString ptr+    free ptr+    return ret+  | otherwise = ""++-- | Unwrap a foreign pointer to pass to a pure C function.+withForeignPtr' :: (Ptr a -> b) -> ForeignPtr a -> b+withForeignPtr' inner arg = unsafePerformIO $ withForeignPtr arg $ return . inner++-- I don't want to pull in all of inline-c for JUST this util!+-- | Pass a transient pointer to an impure C function,+-- for its value to be returned alongside that functions' return value.+withPtr :: (Storable a) => (Ptr a -> IO b) -> IO (a, b)+withPtr f = do+  alloca $ \ptr -> do+    x <- f ptr+    y <- peek ptr+    return (y, x)
+ lib/Graphics/Text/Font/Choose/Internal/Test.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE CApiFFI #-}+-- | Internal C routines which need to be QuickCheck tested.+module Graphics.Text.Font.Choose.Internal.Test where++import Foreign.C.String (CString)+import Foreign.Ptr (Ptr)+import Data.MessagePack (MessagePack)+import Graphics.Text.Font.Choose.Internal.FFI++-- | A C test function which transcodes data into & out of FontConfig datastructures.+type RoundTrip = CString -> Int -> Ptr Int -> CString+-- | Test a roundtrip function, the output should be equal to the input+-- (wrapped in a Maybe type).+roundtrip :: MessagePack a => RoundTrip -> a -> Maybe a+roundtrip fn = fromMessage . withMessage fn++-- | C test function for StrSet type.+foreign import capi "transcode.h" testStrSet :: RoundTrip+-- | C test function for CharSet type.+foreign import capi "transcode.h" testCharSet :: RoundTrip+-- | C test function for LangSet type.+foreign import capi "transcode.h" testLangSet :: RoundTrip+-- | C test function for Range type.+foreign import capi "transcode.h" testRange :: RoundTrip+-- | C test function for Matrix type.+foreign import capi "transcode.h" testMatrix :: RoundTrip+-- | C test function for Value type.+foreign import capi "transcode.h" testValue :: RoundTrip+-- | C test function for Pattern type.+foreign import capi "transcode.h" testPattern :: RoundTrip+-- | C test function for FontSet type.+foreign import capi "transcode.h" testFontSet :: RoundTrip
+ lib/Graphics/Text/Font/Choose/LangSet.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE CApiFFI #-}+-- | Languages supported by different fonts.+module Graphics.Text.Font.Choose.LangSet(+        LangSet, LangSet'(..), module S, LangComparison(..), validLangSet, validLangSet',+        cmp, cmp', has, defaultLangs, langs, normalize, langCharSet) where++import Data.Set as S hiding (valid)++import Data.Hashable (Hashable(..))+import Data.MessagePack (MessagePack(..))+import Test.QuickCheck (Arbitrary(..), elements, listOf)+import Graphics.Text.Font.Choose.StrSet (StrSet(..))+import Graphics.Text.Font.Choose.CharSet as CS (CharSet'(..), empty)++import Foreign.C.String (CString)+import Foreign.Ptr (Ptr)+import Graphics.Text.Font.Choose.Internal.FFI (withMessage, fromMessage0, withCString', peekCString')+import Graphics.Text.Font.Choose.Result+import Control.Exception (throw)++-- | 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+-- | Wrapper around LangSet adding useful typeclasses+newtype LangSet' = LangSet' { unLangSet :: LangSet } deriving (Eq, Show, Read)++instance Hashable LangSet' where+    hashWithSalt salt (LangSet' self) = hashWithSalt salt self++-- | Can the given LangSet be processed by FontConfig?+validLangSet :: LangSet -> Bool+validLangSet x = all validLang x && not (Prelude.null x)+-- | Can the given LangSet' be processed by FontConfig?+validLangSet' :: LangSet' -> Bool+validLangSet' = validLangSet . unLangSet+-- | Can the given language code be processed by FontConfig?+validLang :: String -> Bool+validLang = (`elem` unStrSet langs)++instance MessagePack LangSet' where+    toObject = toObject . S.toList . unLangSet+    fromObject msg = LangSet' <$> S.fromList <$> fromObject msg+instance Arbitrary LangSet' where+    arbitrary = LangSet' <$> S.fromList <$> listOf (elements $ S.toList $ unStrSet langs)++-- | The result of `cmp`.+data LangComparison = DifferentLang -- ^ The locales share no languages in common+    | SameLang -- ^ The locales share any language and territory pair+    | DifferentTerritory -- ^ The locales share a language but differ in which territory that language is for+    deriving (Read, Show, Eq, Enum, Bounded)+i2cmp :: Int -> LangComparison+i2cmp 0 = DifferentLang+i2cmp 1 = SameLang+i2cmp 2 = DifferentTerritory+i2cmp _ = throw ErrOOM++-- | Variation of `cmp` which operates on `LangSet'`.+cmp' :: LangSet' -> LangSet' -> LangComparison+cmp' a b | valid a && valid b = i2cmp $ withMessage fcLangSetCompare [a, b]+    | otherwise = DifferentLang+  where valid = validLangSet'+-- | Compares language coverage for the 2 given LangSets.+cmp :: LangSet -> LangSet -> LangComparison+cmp a b = LangSet' a `cmp'` LangSet' b++foreign import capi "fontconfig-wrap.h" fcLangSetCompare :: CString -> Int -> Int++-- | returns True if `a` contains every language in `b`.+-- `a`` will contain a language from `b` if `a` has exactly the language,+-- or either the language or `a` has no territory.+has :: LangSet' -> String -> LangComparison+has a b | validLangSet' a && validLang b =+        i2cmp $ flip withCString' b $ withMessage fcLangSetHasLang a+    | otherwise = DifferentLang++foreign import capi "fontconfig-wrap.h" fcLangSetHasLang :: CString -> Int -> CString -> Int++-- | 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 :: StrSet+defaultLangs = fromMessage0 fcGetDefaultLangs++foreign import capi "fontconfig-wrap.h" fcGetDefaultLangs :: Ptr Int -> CString++-- | Returns a string set of all languages.+langs :: StrSet+langs = fromMessage0 fcGetLangs++foreign import capi "fontconfig-wrap.h" fcGetLangs :: Ptr Int -> CString++-- | Returns a string to make lang suitable on fontconfig.+normalize :: String -> String+normalize = peekCString' . withCString' fcLangNormalize++foreign import capi "fontconfig-wrap.h" fcLangNormalize :: CString -> CString++-- | Returns the CharSet for a language.+langCharSet :: String -> CharSet'+langCharSet a | validLang a = fromMessage0 $ withCString' fcLangGetCharSet a+    | otherwise = CharSet' CS.empty++foreign import capi "fontconfig-wrap.h" fcLangGetCharSet :: CString -> Ptr Int -> CString
+ lib/Graphics/Text/Font/Choose/ObjectSet.hs view
@@ -0,0 +1,8 @@+-- | Which properties of a font do we want to read?+module Graphics.Text.Font.Choose.ObjectSet(ObjectSet) where++-- | Holds a list of pattern property names; it is used to indicate which+-- properties are to be returned in the patterns from FcFontList.+type ObjectSet = [String]++-- NOTE: Already has all the typeclass instances I want, including MessagePack!
+ lib/Graphics/Text/Font/Choose/Pattern.hs view
@@ -0,0 +1,337 @@+{-# LANGUAGE DeriveGeneric, CApiFFI #-}+{-# LANGUAGE OverloadedStrings #-}+-- | Dynamically-typed datastructure describing a font, whether resolved or a query.+-- Can be parsed from CSS.+module Graphics.Text.Font.Choose.Pattern(Pattern, Pattern'(..), module M, Binding(..),+        setValue, setValues, getValue, getValues, equalSubset, defaultSubstitute,+        nameParse, nameUnparse, nameFormat, validPattern, validPattern',+        -- For Graphics.Text.Font.Choose.FontSet+        parseFontStretch, parseFontWeight, parseFontFeatures, parseFontVars) where++import Data.Map as M+import Data.MessagePack (MessagePack(..), Object(..))+import Test.QuickCheck (Arbitrary(..), elements)+import Data.Hashable (Hashable(..))+import GHC.Generics (Generic)++import Foreign.C.String (CString)+import Foreign.Ptr (Ptr)+import Control.Exception (throw)+import Graphics.Text.Font.Choose.Internal.FFI (withMessage, fromMessage0, withCString', peekCString')++import Graphics.Text.Font.Choose.Value+import Graphics.Text.Font.Choose.ObjectSet+import Graphics.Text.Font.Choose.Result+import Graphics.Text.Font.Choose.Weight++import Stylist (PropertyParser(..), parseUnorderedShorthand', parseOperands)+import Data.CSS.Syntax.Tokens (Token(..), NumericValue(..))+import Data.Text (Text, unpack)+import qualified Data.Text as Txt+import Data.List (intercalate)+import Data.Scientific (toRealFloat)+import Data.Maybe as Mb (listToMaybe, fromMaybe, mapMaybe)+import Data.Char (isAscii)+import Prelude as L++-- | Holds both patterns to match against the available fonts, as well as the information about each font.+type Pattern = M.Map Text [(Binding, Value)]+-- | Wrapper around `Pattern` supporting useful typeclasses.+data Pattern' = Pattern' { unPattern :: Pattern } deriving (Eq, Read, Show, Generic)+-- | The precedance for a field of a Pattern.+data Binding = Strong | Weak | Same deriving (Eq, Ord, Enum, Read, Show, Generic)++instance Hashable Binding where+    hash = fromEnum+instance MessagePack Binding where+    fromObject (ObjectBool True) = Just Strong+    fromObject (ObjectBool False) = Just Weak+    fromObject ObjectNil = Just Same+    fromObject _ = Nothing+    toObject Strong = ObjectBool True+    toObject Weak = ObjectBool False+    toObject Same = ObjectNil++instance Hashable Pattern' where hash = hash . unPattern+instance MessagePack Pattern' where+    fromObject = fmap Pattern' . fromObject+    toObject = toObject . unPattern++instance Arbitrary Pattern' where+    -- FIXME: Stop enforcing singletons, without incurring too many invalid patterns!+    arbitrary = Pattern' <$> M.mapKeys normKey <$> M.map (:[]) <$> arbitrary+        where+            normKey = Txt.pack . L.filter (/= '\0') . L.map toAscii . L.take 17+            toAscii :: Char -> Char+            toAscii ch = toEnum $ fromEnum ch `mod` 128+instance Arbitrary Binding where+    arbitrary = elements [Strong, Weak] -- Same doesn't roundtrip!++-- | Does the pattern hold a value we can process?+validPattern :: Pattern -> Bool+validPattern self = not (M.null self) &&+        all (validValue . snd) (concat $ M.elems self) &&+        all (not . L.null) (M.elems self) &&+        all (not . Txt.null) (M.keys self) &&+        all ((/= Same) . fst) (concat $ M.elems self) &&+        all (not . Txt.elem '\0') (M.keys self) &&+        all (Txt.all isAscii) (M.keys self) &&+        all (\k -> Txt.length k < 18) (M.keys self)+-- | Variant of `validPattern` which applies to the `Pattern'` wrapper.+validPattern' :: Pattern' -> Bool+validPattern' = validPattern . unPattern++-- | Replace a field with a singular type-casted value.+setValue :: ToValue v => Text -> Binding -> v -> Pattern -> Pattern+setValue key strength v self = setValues key strength [v] self+-- | Replace a field with multiple type-casted values.+setValues :: ToValue v => Text -> Binding -> [v] -> Pattern -> Pattern+setValues key strength vs self = M.insert key [(strength, toValue v) | v <- vs] self++-- | Retrieve a field's primary type-casted value.+getValue :: ToValue v => Text -> Pattern -> Maybe v+getValue key self = fromValue . snd =<< listToMaybe =<< M.lookup key self+-- | Retrieve a field's type-casted values.+getValues :: ToValue v => Text -> Pattern -> [v]+getValues key self = Mb.mapMaybe (fromValue . snd) $ fromMaybe [] $ M.lookup key self++-- | Returns whether the given patterns have exactly the same values for all of the given objects.+equalSubset :: Pattern -> Pattern -> ObjectSet -> Bool+equalSubset a b os | validPattern a && validPattern b =+    case withMessage fcPatternEqualSubset [toObject a, toObject b, toObject os] of+        0 -> False+        1 -> True+        _ -> throw ErrOOM+  | otherwise = False++foreign import capi "fontconfig-wrap.h" fcPatternEqualSubset :: CString -> Int -> Int++-- | 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 a | validPattern a = fromMessage0 $ withMessage fcDefaultSubstitute a+    | otherwise = a++foreign import capi "fontconfig-wrap.h" fcDefaultSubstitute :: CString -> Int -> Ptr Int -> CString++-- | Converts name from the standard text format described above into a pattern.+nameParse :: String -> Pattern+nameParse = fromMessage0 . withCString' fcNameParse++foreign import capi "fontconfig-wrap.h" fcNameParse :: CString -> Ptr Int -> CString++-- | Converts the given pattern into the standard text format described above.+nameUnparse :: Pattern -> String+nameUnparse a | validPattern a = peekCString' $ withMessage fcNameUnparse a+    | otherwise = ""++foreign import capi "fontconfig-wrap.h" fcNameUnparse :: CString -> Int -> CString++-- | Format a pattern into a string according to a format specifier+-- See https://fontconfig.pages.freedesktop.org/fontconfig/fontconfig-devel/fcpatternformat.html for full details.+nameFormat :: Pattern -> String -> String+nameFormat a b+    | validPattern a = peekCString' $ flip withCString' b $ withMessage fcNameFormat a+    | otherwise = ""++foreign import capi "fontconfig-wrap.h" fcNameFormat :: CString -> Int -> CString -> CString++------+--- CSS+------++parseFontFamily :: [Token] -> ([String], Bool, [Token])+parseFontFamily (String font:Comma:toks) = let (fonts, b, tail') = parseFontFamily toks+    in (unpack font:fonts, b, tail')+parseFontFamily (Ident font:Comma:toks) = let (fonts, b, tail') = parseFontFamily toks+    in (unpack font:fonts, b, tail')+parseFontFamily (String font:toks) = ([unpack font], True, toks)+parseFontFamily (Ident font:toks) = ([unpack font], True, toks)+parseFontFamily toks = ([], False, toks) -- Invalid syntax!++parseFontFeatures :: [Token] -> ([(String, Int)], Bool, [Token])+parseFontFeatures (String feat:toks) | feature@(_:_:_:_:[]) <- unpack feat = case toks of+    Comma:toks' -> let (feats, b, tail') = parseFontFeatures toks' in ((feature, 1):feats, b, tail')+    Ident "on":Comma:toks' -> let (f, b, t) = parseFontFeatures toks' in ((feature, 1):f, b, t)+    Ident "on":toks' -> ([(feature, 1)], L.null toks', toks')+    Ident "off":Comma:toks' -> let (f, b, t) = parseFontFeatures toks' in ((feature, 1):f, b, t)+    Ident "off":toks' -> ([(feature, 1)], L.null toks', toks')+    Number _ (NVInteger x):Comma:toks' ->+        let (feats, b, tail') = parseFontFeatures toks' in ((feature, fromEnum x):feats, b, tail')+    Number _ (NVInteger x):toks' -> ([(feature, fromEnum x)], L.null toks', toks')+    _ -> ([(feature, 1)], L.null toks, toks)+parseFontFeatures toks = ([], False, toks)++-- | Parse OpenType variables from CSS syntax.+parseFontVars :: [Token] -> ([(String, Double)], Bool, [Token])+parseFontVars (String var':Number _ x:Comma:toks) | var@(_:_:_:_:[]) <- unpack var' =+    let (vars, b, tail') = parseFontVars toks in ((var, nv2double x):vars, b, tail')+parseFontVars (String var':Number _ x:toks) | var@(_:_:_:_:[]) <- unpack var' =+    ([(var, nv2double x)], True, toks)+parseFontVars toks = ([], False, toks)++parseLength :: Double -> NumericValue -> Text -> Double+parseLength super len unit = convert (nv2double len) 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++-- | Parse the CSS font-stretch property.+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.+-- | Parse the CSS font-weight property.+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 :: NumericValue -> Double+nv2double (NVInteger x) = fromInteger x+nv2double (NVNumber x) = toRealFloat x++sets :: ToValue v => Text -> Binding -> [v] -> Pattern -> Maybe Pattern+sets a b c d = Just $ setValues a b c d+set :: ToValue v => Text -> Binding -> v -> Pattern -> Maybe Pattern+set a b c d = Just $ setValue a b c d+seti :: Text -> Binding -> Int -> Pattern -> Maybe Pattern+seti a b c d = Just $ setValue a b (c :: Int) d+unset' :: Text -> Pattern -> Maybe Pattern+unset' a b = Just $ M.delete a b++getSize :: Pattern -> Double+getSize pat | Just [(_, ValueDouble x)] <- M.lookup "size" pat = x+    | otherwise = 10++instance PropertyParser Pattern' where+    temp = Pattern' M.empty++    longhand _ (Pattern' self) "font-family" toks+        | (fonts, True, []) <- parseFontFamily toks = Pattern' <$> sets "family" Strong fonts self++    -- font-size: initial should be configurable!+    longhand (Pattern' super) (Pattern' self) "font-size" [Dimension _ x unit]+        | let y = parseLength (getSize super) x unit, not $ isNaN y =+            Pattern' <$> set "size" Strong y self+    longhand super self "font-size" [Percentage x y] =+        longhand super self "font-size" [Dimension x y "%"]+    -- NOTE: Approximate implementation, caller should supply a real one!+    longhand (Pattern' super) (Pattern' self) "font-size" [Ident x] =+        let y = 10 :: Double in Pattern' <$> case x of+            -- NOTE: If a caller wants to be more precise about the base size (a.k.a `y`)+            -- they should parse it themselves!+            "xx-small" -> set "size" Strong (3/5*y) self+            "x-small" -> set "size" Strong (3/4*y) self+            "small" -> set "size" Strong (8/9*y) self+            "medium" -> set "size" Strong y self+            "large" -> set "size" Strong (6/5*y) self+            "x-large" -> set "size" Strong (3/2*y) self+            "xx-large" -> set "size" Strong (2*y) self+            "xxx-large" -> set "size" Strong (3*y) self+            -- NOTE: Spec encourages a more complex formula, caller should implement!+            "smaller" -> set "size" Strong (getSize super/1.2) self+            "larger" -> set "size" Strong (getSize super*1.2) self+            _ -> Nothing++    longhand _ (Pattern' self) "font-style" [Ident "initial"] = Pattern' <$> seti "slant" Strong 0 self+    longhand _ (Pattern' self) "font-style" [Ident "normal"] = Pattern' <$> seti "slant" Strong 0 self+    longhand _ (Pattern' self) "font-style" [Ident "italic"] = Pattern' <$> seti "slant" Strong 100 self+    longhand _ (Pattern' self) "font-style" [Ident "oblique"] = Pattern' <$> seti "slant" Strong 110 self+    longhand _ (Pattern' self) "font-style" [Ident "oblique", Dimension _ _ unit]+        | unit `elem` Txt.words "deg grad rad turn" = Pattern' <$> seti "slant" Strong 110 self++    -- Conversion between CSS scale & FontConfig scale is non-trivial, use lookuptable.+    -- FIXME: Use Graphics.Text.Font.Choose.Weight!+    longhand _ (Pattern' self) "font-weight" [tok]+        | Just x <- parseFontWeight tok = Pattern' <$> 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 _ (Pattern' self) "font-weight" [Ident "lighter"]+        | Just ((_, ValueInt x):_) <- M.lookup "weight" self, x > 200 =+            Pattern' <$> seti "weight" Strong 200 self+        -- minus 100 adhears to the CSS standard awefully well in this new scale.+        | Just ((_, ValueInt x):_) <- M.lookup "weight" self =+            Pattern' <$> seti "weight" Strong (max (x - 100) 0) self+        | otherwise = Pattern' <$> seti "weight" Strong 0 self+    longhand _ self'@(Pattern' self) "font-weight" [Ident "bolder"]+        | Just ((_, ValueInt x):_) <- M.lookup "weight" self, x <= 65 =+            Pattern' <$> seti "weight" Strong 80 self+        | Just ((_, ValueInt x):_) <- M.lookup "weight" self, x <= 150 =+            Pattern' <$> seti "weight" Strong 200 self+        | Just ((_, ValueInt x):_) <- M.lookup "weight" self, x < 210 =+            Pattern' <$> seti "weight" Strong 210 self+        | Just ((_, ValueInt _):_) <- M.lookup "weight" self = Just self' -- As bold as it goes...+        | otherwise = Pattern' <$> seti "weight" Strong 200 self++    longhand _ (Pattern' self) "font-feature-settings" [Ident k]+        | k `elem` ["initial", "normal"] = Pattern' <$> unset' "fontfeatures" self+    longhand _ (Pattern' self) "font-feature-settings" toks+        | (features, True, []) <- parseFontFeatures toks = Pattern' <$>+            sets "fontfeatures" Strong (L.map fst features) self++    longhand _ (Pattern' self) "font-variation-settings" [Ident k]+        | k `elem` ["initial", "normal"] = Pattern' <$> unset' "variable" self+    longhand _ (Pattern' self) "font-variation-settings" toks+        | (vars , True, []) <- parseFontVars toks =+            Pattern' <$> (set "variable" Strong True =<<+                set "fontvariations" Strong (intercalate "," $ L.map fst vars) self)++    longhand _ (Pattern' s) "font-stretch" [tok]+        | Just x <- parseFontStretch tok = Pattern' <$> seti "width" Strong x s++    longhand _ _ _ _ = Nothing++    shorthand self "font" toks = case parseOperands toks of+        (a:b:c:d:toks') | ret@(_:_) <- unordered [a,b,c,d] -> inner ret toks'+        (a:b:c:toks') | ret@(_:_) <- unordered [a,b,c] -> inner ret toks'+        (a:b:toks') | ret@(_:_) <- unordered [a,b] -> inner ret toks'+        (a:toks') | ret@(_:_) <- unordered [a] -> inner ret toks'+        toks' -> inner [] toks'+      where+        unordered operands =+          let ret = parseUnorderedShorthand' self [+                        "font-style", "font-variant", "font-weight", "font-stretch"+                    ] operands+          in if ("", []) `elem` ret then [] else ret -- Check for errors!+        inner ret (sz:[Delim '/']:height:family)+            | Just _ <- longhand self self "font-size" sz,+              Just _ <- longhand self self "line-height" height,+              Just _ <- longhand self self "font-family" $ concat family =+                ("font-size", sz):("line-height", height):+                    ("font-family", concat family):ret+            | otherwise = []+        inner ret (sz:family)+            | Just _ <- longhand self self "font-size" sz,+              Just _ <- longhand self self "font-family" $ concat family =+                ("font-size", sz):("line-height", [Ident "initial"]):+                    ("font-family", concat family):ret+            | otherwise = []+        inner _ _ = []++    shorthand self k v | Just _ <- longhand self self k v = [(k, v)]+        | otherwise = []
+ lib/Graphics/Text/Font/Choose/Range.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE DeriveGeneric #-}+-- | A range between 2 values.+module Graphics.Text.Font.Choose.Range(Range(..), iRange, validRange) where++import Data.MessagePack (MessagePack(..), Object(..))+import Test.QuickCheck (Arbitrary(..))+import GHC.Generics (Generic(..))+import Data.Hashable (Hashable(..))+import qualified Data.Vector as V+import qualified Data.IntMap as IM++-- | Matches a numeric range, bounded by 2 floating point numbers.+data Range = Range Double Double deriving (Eq, Read, Show, Ord, Generic)+-- | Matches an integral range.+iRange :: Int -> Int -> Range+iRange i j = toEnum i `Range` toEnum j++instance MessagePack Range where+    toObject (Range start end) = ObjectMap $ V.fromList [+        (ObjectInt 0, ObjectDouble start),+        (ObjectInt 1, ObjectDouble end)+      ]+    fromObject msg+        | Just msg' <- fromObject msg =+            Just (IM.findWithDefault 0 0 msg' `Range` IM.findWithDefault 0 1 msg')+        | otherwise = Nothing+instance Arbitrary Range where+    arbitrary = do+        (a, b) <- arbitrary+        return $ Range a $ a + abs b + 1+instance Hashable Range++-- | Can FontConfig process this range?+validRange :: Range -> Bool+validRange (Range start end) = start < end
+ lib/Graphics/Text/Font/Choose/Result.hs view
@@ -0,0 +1,25 @@+-- | Exceptions which can be thrown by FontConfig.+module Graphics.Text.Font.Choose.Result (FcException(..), throwBool, throwNull, throwString) where++import Foreign.Ptr (Ptr, nullPtr)+import Text.Read (readMaybe)+import Control.Exception (Exception, throwIO)++-- | Exceptions which can be thrown by FontConfig.+data FcException = ErrType | ErrNoId | ErrOOM | ErrOther deriving (Read, Show, Eq, Enum)+instance Exception FcException++-- | Converts a pass|failure return value into a Haskell exception.+throwBool :: Bool -> IO ()+throwBool False = throwIO ErrOOM+throwBool True = return ()++-- | Turns a failed allocation into a Haskell exception.+throwNull :: Ptr a -> IO (Ptr a)+throwNull a | a == nullPtr = throwIO ErrOOM+    | otherwise = return a++-- | Turns a serialized string into a Haskell exception.+throwString :: String -> IO ()+throwString a | Just b <- readMaybe a :: Maybe FcException = throwIO b+    | otherwise = return ()
+ lib/Graphics/Text/Font/Choose/StrSet.hs view
@@ -0,0 +1,21 @@+-- | A set of strings to match.+module Graphics.Text.Font.Choose.StrSet(StrSet(..), module S, validStrSet) where++import Data.Set (Set)+import qualified Data.Set as S++import Data.MessagePack (MessagePack(..))+import Test.QuickCheck (Arbitrary(..))++-- | A set of strings to match.+newtype StrSet = StrSet { unStrSet :: Set String } deriving (Eq, Show, Read)++instance MessagePack StrSet where+    toObject = toObject . S.toList . unStrSet+    fromObject msg = StrSet <$> S.fromList <$> fromObject msg+instance Arbitrary StrSet where+    arbitrary = StrSet <$> S.map (filter (/= '\0')) <$> arbitrary++-- | Whether the StrSet can be processed by FontConfig.+validStrSet :: StrSet -> Bool+validStrSet (StrSet self) = notElem '\0' `all` self
+ lib/Graphics/Text/Font/Choose/Value.hs view
@@ -0,0 +1,135 @@+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+-- | A dynamic type system for patterns.+module Graphics.Text.Font.Choose.Value(Value(..), validValue, ToValue(..)) where++import Linear.Matrix (M22)+import Linear.V2 (V2(..))+import Graphics.Text.Font.Choose.CharSet (CharSet, CharSet'(..), validCharSet')+import qualified Data.IntSet as S+--import FreeType.Core.Base (FT_Face(..))+import Graphics.Text.Font.Choose.LangSet (LangSet, LangSet'(..), validLangSet)+import Graphics.Text.Font.Choose.Range (Range, validRange)++import Data.MessagePack (MessagePack(..), Object(..))+import Test.QuickCheck (Arbitrary(..), oneof)+import GHC.Generics (Generic)+import Data.Hashable (Hashable(..))+import qualified Data.Text as Txt++-- | 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 -- FIXME: Is it worth going through the trouble to bridge this?+    | ValueLangSet LangSet+    | ValueRange Range deriving (Eq, Read, Show, Ord, Generic)++instance Hashable Value+instance MessagePack Value where+    toObject ValueVoid = ObjectNil+    toObject (ValueInt x) = ObjectInt x+    toObject (ValueDouble x) = ObjectDouble x+    toObject (ValueString x) = ObjectStr $ Txt.pack x+    toObject (ValueBool x) = ObjectBool x+    toObject (ValueMatrix (V2 (V2 xx yx) (V2 xy yy))) = toObject [xx, xy, yx, yy]+    toObject (ValueCharSet x) | S.null x = ObjectExt 0x63 "" -- Resolve ambiguity!+        | otherwise = toObject $ CharSet' x+    toObject (ValueLangSet x) = toObject $ LangSet' x+    toObject (ValueRange x) = toObject x++    fromObject ObjectNil = Just ValueVoid+    fromObject (ObjectBool x) = Just $ ValueBool x+    fromObject (ObjectInt x) = Just $ ValueInt x+    fromObject (ObjectFloat x) = Just $ ValueDouble $ realToFrac x+    fromObject (ObjectDouble x) = Just $ ValueDouble x+    fromObject (ObjectStr x) = Just $ ValueString $ Txt.unpack x+    fromObject (ObjectBin _) = Nothing -- Would use for to transfer font faces via underlying bytes.+    fromObject msg+        -- LangSet takes precedance for encoding empty arrays!+        | Just langset <- fromObject msg = Just $ ValueLangSet $ unLangSet langset+        | Just charset <- fromObject msg = Just $ ValueCharSet $ unCharSet charset+        | Just range <- fromObject msg = Just $ ValueRange range+        | Just [xx, xy, yx, yy] <- fromObject msg :: Maybe [Double] =+            -- [Double] decoding is overly generous, potentially conflicts with above.+            Just $ ValueMatrix $ V2 (V2 xx yx) (V2 xy yy)+        | otherwise = Nothing+instance Arbitrary Value where+    arbitrary = oneof [+        --return ValueVoid,+        ValueInt <$> arbitrary,+        ValueDouble <$> arbitrary,+        ValueString <$> Prelude.filter (/= '\0') <$> arbitrary,+        ValueBool <$> arbitrary,+        do+            (a, b, c, d) <- arbitrary+            return $ ValueMatrix $ V2 (V2 a b) (V2 c d),+        ValueCharSet <$> unCharSet <$> arbitrary,+        ValueLangSet <$> unLangSet <$> arbitrary,+        ValueRange <$> arbitrary+      ]++-- | Can the value be processed by FontConfig?+validValue :: Value -> Bool+validValue (ValueString "") = False+validValue (ValueString x) = '\0' `notElem` x+validValue (ValueCharSet x) = validCharSet' $ CharSet' x+validValue (ValueLangSet x) = validLangSet x+validValue (ValueRange x) = validRange x+validValue _ = True++-- | Coerces compiletime types to or from 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' _ = error "Type mismatch!" -- TODO: Throw something nicer!++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 . unCharSet+    fromValue (ValueCharSet x) = Just $ CharSet' x+    fromValue _ = Nothing+--instance ToValue FT_Face where+--    toValue = ValueFTFace+--    fromValue (ValueFTFace x) = Just x+--    fromValue _ = Nothing+instance ToValue LangSet' where+    toValue = ValueLangSet . unLangSet+    fromValue (ValueLangSet x) = Just $ LangSet' x+    fromValue _ = Nothing+instance ToValue Range where+    toValue = ValueRange+    fromValue (ValueRange x) = Just x+    fromValue _ = Nothing+instance ToValue Value where+    toValue = id+    fromValue = Just
+ lib/Graphics/Text/Font/Choose/Weight.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE CApiFFI #-}+-- | Convert between OpenType & FontConfig weight scales.+module Graphics.Text.Font.Choose.Weight(weightFromOpenTypeDouble,+        weightToOpenTypeDouble, weightFromOpenType, weightToOpenType) where++-- | Returns an double value to use with FC_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 capi "fontconfig/fontconfig.h FcWeightFromOpenTypeDouble"+    weightFromOpenTypeDouble :: Double -> Double+-- | the inverse of FcWeightFromOpenType. 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 capi "fontconfig/fontconfig.h FcWeightToOpenTypeDouble"+    weightToOpenTypeDouble :: Double -> Double+-- | Like weightFromOpenTypeDouble but with integer arguments. Use the other function instead.+weightFromOpenType :: Int -> Int+weightFromOpenType = fromEnum . weightFromOpenTypeDouble . toEnum+-- | Like weightToOpenTypeDouble but with integer arguments. Use the other function instead.+weightToOpenType :: Int -> Int+weightToOpenType = fromEnum . weightToOpenTypeDouble . toEnum
+ test/Main.hs view
@@ -0,0 +1,441 @@+{-# LANGUAGE OverloadedStrings #-}++module Main (main) where++import Test.Hspec+import Test.Hspec.QuickCheck+import Test.QuickCheck++import Data.MessagePack as MP+import qualified Data.Map as M+import qualified Data.Set as S+import qualified Data.Text as Txt+import qualified Data.IntSet as IS+import Data.Maybe (isJust, fromMaybe)+import GHC.Real (infinity)++import Graphics.Text.Font.Choose+import Graphics.Text.Font.Choose.Internal.Test+import qualified Graphics.Text.Font.Choose.Pattern as Pat+import Data.CSS.Syntax.Tokens (Token(..), NumericValue(NVInteger), tokenize)+import Stylist (PropertyParser(..))+import qualified Stylist.Parse as CSS++main :: IO ()+main = hspec $ do+    describe "Canary" $ do+        it "runs fine" $ do+            True `shouldBe` True+    describe "Roundtrips" $ do+        describe "converts MessagePack & back" $ do+            prop "CharSet" $ \x ->+                MP.unpack (MP.pack x) `shouldBe` Just (x :: CharSet')+            prop "FontSet" $ \x -> let y = Prelude.map unPattern x+                in MP.unpack (MP.pack y) `shouldBe` Just y+            prop "LangSet" $ \x ->+                MP.unpack (MP.pack x) `shouldBe` Just (x :: LangSet')+            prop "ObjectSet" $ \x ->+                MP.unpack (MP.pack x) `shouldBe` Just (x :: ObjectSet)+            prop "Pattern" $ \x ->+                MP.unpack (MP.pack x) `shouldBe` Just (x :: Pattern')+            prop "Range" $ \x ->+                MP.unpack (MP.pack x) `shouldBe` Just (x :: Range)+            prop "StrSet" $ \x ->+                MP.unpack (MP.pack x) `shouldBe` Just (x :: StrSet)+            prop "Value" $ \x ->+                MP.unpack (MP.pack x) `shouldBe` Just (x :: Value)+        describe "through C datastructures" $ do+            prop "StrSet" $ \x -> validStrSet x ==>+                roundtrip testStrSet x `shouldBe` Just (x :: StrSet)+            prop "CharSet" $ \x -> validCharSet' x ==>+                roundtrip testCharSet x `shouldBe` Just (x :: CharSet')+            prop "LangSet" $ \x -> validLangSet' x ==>+                roundtrip testLangSet x `shouldBe` Just (x :: LangSet')+            prop "Range" $ \x -> validRange x ==>+                roundtrip testRange x `shouldBe` Just (x :: Range)+            prop "Matrix" $ \x -> roundtrip testMatrix x `shouldBe`+                    Just (x :: (Double, Double, Double, Double))+            prop "Value" $ \x -> validValue x ==>+                roundtrip testValue x `shouldBe` Just (x :: Value)+            prop "Trivial Pattern" $ \x -> validValue x ==>+                let pat = Pattern' $ M.fromList [("test", [(Strong, x)])]+                in roundtrip testPattern pat `shouldBe` Just pat+            prop "Tuple Pattern" $ \(x, y) -> validValue x && validValue y ==>+                let pat = Pattern' $ M.fromList [("a", [(Strong, x)]), ("b", [(Strong, y)])]+                in roundtrip testPattern pat `shouldBe` Just pat+            let toAscii :: Char -> Char+                toAscii ch = toEnum $ fromEnum ch `mod` 128+            prop "Random-key pattern" $ \x -> all (\y -> toAscii y /= '\0') x ==>+                let pat = Pattern' $ M.fromList [(Txt.pack $ map toAscii $ take 17 x, [(Strong, ValueBool True)])]+                in roundtrip testPattern pat `shouldBe` Just pat+            prop "Pattern" $ \x -> validPattern' x ==>+                roundtrip testPattern x `shouldBe` Just (x :: Pattern')+            prop "FontSet" $ \x -> let y = filter validPattern $ Prelude.map unPattern x+                in validFontSet y ==> roundtrip testFontSet y `shouldBe` Just y+    describe "FontConfig Testsuite transliteration" $ do+        it "All system fonts should have files" $ do+            conf <- current+            res <- fonts conf System+            let files = getValue "file" `map` res :: [Maybe String]+            all isJust files `shouldBe` True+        it "Locale compare" $ do+            S.singleton "ku-am" `cmp` S.singleton "ku-iq" `shouldBe` DifferentTerritory+            S.singleton "ku-am" `cmp` S.singleton "ku-ir" `shouldBe` DifferentTerritory+            S.singleton "ku-am" `cmp` S.singleton "ku-tr" `shouldBe` DifferentTerritory+            S.singleton "ku-iq" `cmp` S.singleton "ku-ir" `shouldBe` DifferentTerritory+            S.singleton "ku-iq" `cmp` S.singleton "ku-tr" `shouldBe` DifferentTerritory+            S.singleton "ku-ir" `cmp` S.singleton "ku-tr" `shouldBe` DifferentTerritory+            S.singleton "ps-af" `cmp` S.singleton "ps-pk" `shouldBe` DifferentTerritory+            S.singleton "ti-er" `cmp` S.singleton "ti-et" `shouldBe` DifferentTerritory+            S.singleton "zh-cn" `cmp` S.singleton "zh-hk" `shouldBe` DifferentTerritory+            S.singleton "zh-cn" `cmp` S.singleton "zh-mo" `shouldBe` DifferentTerritory+            S.singleton "zh-cn" `cmp` S.singleton "zh-sg" `shouldBe` DifferentTerritory+            S.singleton "zh-cn" `cmp` S.singleton "zh-tw" `shouldBe` DifferentTerritory+            S.singleton "zh-hk" `cmp` S.singleton "zh-mo" `shouldBe` DifferentTerritory+            S.singleton "zh-hk" `cmp` S.singleton "zh-sg" `shouldBe` DifferentTerritory+            S.singleton "zh-hk" `cmp` S.singleton "zh-tw" `shouldBe` DifferentTerritory+            S.singleton "zh-mo" `cmp` S.singleton "zh-sg" `shouldBe` DifferentTerritory+            S.singleton "zh-mo" `cmp` S.singleton "zh-tw" `shouldBe` DifferentTerritory+            S.singleton "zh-sg" `cmp` S.singleton "zh-tw" `shouldBe` DifferentTerritory+            S.singleton "mn-mn" `cmp` S.singleton "mn-cn" `shouldBe` DifferentTerritory+            S.singleton "pap-an" `cmp` S.singleton "pap-aw" `shouldBe` DifferentTerritory+            -- A couple additional ones so we know its not always responding with DifferentTerritory!+            S.singleton "mn-mn" `cmp` S.singleton "mn-mn" `shouldBe` SameLang+            S.singleton "mn-mn" `cmp` S.singleton "pap-an" `shouldBe` DifferentLang+        it "Font weights" $ do+            weightFromOpenTypeDouble (fromRational infinity) `shouldBe` 215+            weightFromOpenType maxBound `shouldBe` 215+        it "Name parsing" $ do+            nameParse "sans\\-serif" `shouldBe` M.fromList [+                ("family", [(Strong, ValueString "sans-serif")])+              ]+            nameParse "Foo-10" `shouldBe` M.fromList [+                ("family", [(Strong, ValueString "Foo")]),+                -- NOTE: Equality derived from the pure-Haskell type is stricter than FontConfig's.+                -- This subtest might fail in the future, not sure what to do about that.+                ("size", [(Strong, ValueDouble 10)])+              ]+            nameParse "Foo,Bar-10" `shouldBe` M.fromList [+                ("family", [(Strong, ValueString "Foo"), (Strong, ValueString "Bar")]),+                ("size", [(Strong, ValueDouble 10)])+              ]+            nameParse "Foo:weight=medium" `shouldBe` M.fromList [+                ("family", [(Strong, ValueString "Foo")]),+                ("weight", [(Strong, ValueDouble 100)])+              ]+            nameParse "Foo:weight_medium" `shouldBe` M.fromList [+                ("family", [(Strong, ValueString "Foo")]),+                ("weight", [(Strong, ValueDouble 100)])+              ]+            nameParse ":medium" `shouldBe` M.fromList [+                ("weight", [(Strong, ValueInt 100)])+              ]+            nameParse ":normal" `shouldBe` M.fromList [+                ("weight", [(Strong, ValueInt 80)])+              ]+            nameParse ":weight=[medium bold]" `shouldBe` M.fromList [+                ("weight", [(Strong, ValueRange $ Range 100 200)])+              ]+    describe "CSS Parsing" $ do+        -- Taking test cases from MDN!+        it "unicode-range" $ do+            let parseCharSet' = IS.toList . fromMaybe IS.empty . parseCharSet+            parseCharSet' "U+26" `shouldBe` [0x26]+            parseCharSet' "U+26, U+42" `shouldBe` [0x26, 0x42]+            parseCharSet' "U+0-7F" `shouldBe` [0x0..0x7f]+            parseCharSet' "U+0025-00FF" `shouldBe` [0x0025..0x00ff]+            parseCharSet' "U+4??" `shouldBe` [0x400..0x4ff]+            parseCharSet' "U+0025-00FF, U+4??" `shouldBe` [0x0025..0x00ff] ++ [0x400..0x4ff]+        it "font-stretch" $ do+            let parseFontStretch' = Pat.parseFontStretch . Ident+            let parseFontStretch_ = Pat.parseFontStretch . Percentage "" . NVInteger+            parseFontStretch' "condensed" `shouldBe` Just 75+            parseFontStretch' "expanded" `shouldBe` Just 125+            parseFontStretch' "ultra-expanded" `shouldBe` Just 200+            parseFontStretch_ 50 `shouldBe` Just 50+            parseFontStretch_ 100 `shouldBe` Just 100+            parseFontStretch_ 150 `shouldBe` Just 150+        it "font-weight" $ do+            let parseFontWeight' = Pat.parseFontWeight . Ident+            let parseFontWeight_ = Pat.parseFontWeight . Number "" . NVInteger+            parseFontWeight' "normal" `shouldBe` Just 80+            parseFontWeight' "bold" `shouldBe` Just 200+            parseFontWeight_ 100 `shouldBe` Just 0+            parseFontWeight_ 900 `shouldBe` Just 210+        it "font-feature-settings" $ do+            Pat.parseFontFeatures [String "liga", Number "0" $ NVInteger 0] `shouldBe` ([+                ("liga", 0)+              ], True, [])+            Pat.parseFontFeatures [String "tnum"] `shouldBe` ([+                ("tnum", 1)+              ], True, [])+            Pat.parseFontFeatures [String "tnum"] `shouldBe` ([+                ("tnum", 1)+              ], True, [])+            Pat.parseFontFeatures [String "scmp", Comma, String "zero"] `shouldBe` ([+                ("scmp", 1),+                ("zero", 1)+              ], True, [])+        it "font-variation-settings" $ do+            Pat.parseFontVars [String "wght", Number "50" $ NVInteger 50] `shouldBe` ([+                ("wght", 50)+              ], True, [])+            Pat.parseFontVars [String "wght", Number "850" $ NVInteger 850] `shouldBe` ([+                ("wght", 850)+              ], True, [])+            Pat.parseFontVars [String "wdth", Number "25" $ NVInteger 25] `shouldBe` ([+                ("wdth", 25)+              ], True, [])+            Pat.parseFontVars [String "wdth", Number "75" $ NVInteger 75] `shouldBe` ([+                ("wdth", 75)+              ], True, [])+        it "To FontConfig pattern" $ do+            let tProp k v =+                  longhand temp temp k $ filter (/= Whitespace) $ tokenize v+            let list2pat' = Pattern' . M.fromList+            let list2pat = Just . list2pat'++            tProp "font-family" "Georgia, serif" `shouldBe` list2pat [+                    ("family", [(Strong, ValueString "Georgia"), (Strong, ValueString "serif")])+                ]+            tProp "font-family" "\"Gill Sans\", sans-serif" `shouldBe` list2pat [+                    ("family", [+                        (Strong, ValueString "Gill Sans"),+                        (Strong, ValueString "sans-serif")+                    ])+                ]+            tProp "font-family" "sans-serif" `shouldBe` list2pat [+                ("family", [(Strong, ValueString "sans-serif")])+              ]+            tProp "font-family" "serif" `shouldBe` list2pat [+                ("family", [(Strong, ValueString "serif")])+              ]+            tProp "font-family" "cursive" `shouldBe` list2pat [+                ("family", [(Strong, ValueString "cursive")])+              ]+            tProp "font-family" "system-ui" `shouldBe` list2pat [+                ("family", [(Strong, ValueString "system-ui")])+              ]++            tProp "font-size" "1.2em" `shouldBe` list2pat [+                ("size", [(Strong, ValueDouble 12)])+              ]+            tProp "font-size" "x-small" `shouldBe` list2pat [+                ("size", [(Strong, ValueDouble 7.5)])+              ]+            tProp "font-size" "smaller" `shouldBe` list2pat [+                ("size", [(Strong, ValueDouble 8.333333333333334)])+              ]+            tProp "font-size" "12px" `shouldBe` list2pat [+                ("size", [(Strong, ValueDouble $ 0.125/72)])+              ]+            tProp "font-size" "80%" `shouldBe` list2pat [+                ("size", [(Strong, ValueDouble 8)])+              ]++            tProp "font-style" "normal" `shouldBe` list2pat [+                ("slant", [(Strong, ValueInt 0)])+              ]+            tProp "font-style" "italic" `shouldBe` list2pat [+                ("slant", [(Strong, ValueInt 100)])+              ]+            tProp "font-style" "oblique" `shouldBe` list2pat [+                ("slant", [(Strong, ValueInt 110)])+              ]+            tProp "font-style" "oblique 40deg" `shouldBe` list2pat [+                ("slant", [(Strong, ValueInt 110)])+              ]++            tProp "font-weight" "normal" `shouldBe` list2pat [+                ("weight", [(Strong, ValueInt 80)])+              ]+            tProp "font-weight" "bold" `shouldBe` list2pat [+                ("weight", [(Strong, ValueInt 200)])+              ]+            tProp "font-weight" "lighter" `shouldBe` list2pat [+                ("weight", [(Strong, ValueInt 0)])+              ]+            tProp "font-weight" "bolder" `shouldBe` list2pat [+                ("weight", [(Strong, ValueInt 200)])+              ]+            tProp "font-weight" "100" `shouldBe` list2pat [+                ("weight", [(Strong, ValueInt 0)])+              ]+            tProp "font-weight" "900" `shouldBe` list2pat [+                ("weight", [(Strong, ValueInt 210)])+              ]++            tProp "font-feature-settings" "normal" `shouldBe` list2pat []+            tProp "font-feature-settings" "\"liga\" 0" `shouldBe` list2pat [+                ("fontfeatures", [(Strong, ValueString "liga")])+              ]+            tProp "font-feature-settings" "\"tnum\"" `shouldBe` list2pat [+                ("fontfeatures", [(Strong, ValueString "tnum")])+              ]+            tProp "font-feature-settings" "\"smcp\", \"zero\"" `shouldBe` list2pat [+                ("fontfeatures", [+                    (Strong, ValueString "smcp"),+                    (Strong, ValueString "zero")+                ])+              ]++            tProp "font-variation-settings" "'wght' 50" `shouldBe` list2pat [+                ("variable", [(Strong, ValueBool True)]),+                ("fontvariations", [(Strong, ValueString "wght")])+              ]+            tProp "font-variation-settings" "'wght' 850" `shouldBe` list2pat [+                ("variable", [(Strong, ValueBool True)]),+                ("fontvariations", [(Strong, ValueString "wght")])+              ]+            tProp "font-variation-settings" "'wdth' 25" `shouldBe` list2pat [+                ("variable", [(Strong, ValueBool True)]),+                ("fontvariations", [(Strong, ValueString "wdth")])+              ]+            tProp "font-variation-settings" "'wdth' 75" `shouldBe` list2pat [+                ("variable", [(Strong, ValueBool True)]),+                ("fontvariations", [(Strong, ValueString "wdth")])+              ]++            tProp "font-stretch" "condensed" `shouldBe` list2pat [+                ("width", [(Strong, ValueInt 75)])+              ]+            tProp "font-stretch" "expanded" `shouldBe` list2pat [+                ("width", [(Strong, ValueInt 125)])+              ]+            tProp "font-stretch" "ultra-expanded" `shouldBe` list2pat [+                ("width", [(Strong, ValueInt 200)])+              ]+            tProp "font-stretch" "50%" `shouldBe` list2pat [+                ("width", [(Strong, ValueInt 50)])+              ]+            tProp "font-stretch" "100%" `shouldBe` list2pat [+                ("width", [(Strong, ValueInt 100)])+              ]+            tProp "font-stretch" "150%" `shouldBe` list2pat [+                ("width", [(Strong, ValueInt 150)])+              ]++            let tShort :: PropertyParser p => Txt.Text -> Txt.Text -> p+                tShort k v = let temp' = temp in+                    foldl (\self (key, val) ->+                            fromMaybe self $ longhand (inherit temp') self key val)+                        temp' $ shorthand temp' k $ filter (/= Whitespace) $ tokenize v+            tShort "font" "1.2em 'Fira Sans', sans-serif" `shouldBe` list2pat' [+                ("size", [(Strong, ValueDouble 12)]),+                ("family", [(Strong, ValueString "Fira Sans"), (Strong, ValueString "sans-serif")])+              ]+            tShort "font" "italic 1.2em 'Fira Sans', serif" `shouldBe` list2pat' [+                ("slant", [(Strong, ValueInt 100)]),+                ("size", [(Strong, ValueDouble 12)]),+                ("family", [(Strong, ValueString "Fira Sans"), (Strong, ValueString "serif")]),+                ("weight",[(Strong,ValueInt 80)]), ("width",[(Strong,ValueInt 100)])+              ]+            tShort "font" "italic bold 16px cursive" `shouldBe` list2pat' [+                ("slant", [(Strong, ValueInt 100)]),+                ("size", [(Strong, ValueDouble 2.3148148148148147e-3)]),+                ("weight", [(Strong, ValueInt 200)]),+                ("family", [(Strong, ValueString "cursive")]),+                ("width",[(Strong,ValueInt 100)])+              ]+        it "@font-face" $ do+            let tRule = cssFonts . CSS.parse (emptyParser ())+            let tRule' = tRule . Txt.unlines+            let list2pat = M.fromList+            tRule "" `shouldBe` []+            tRule "@font-face {font-family: OpenSans}" `shouldBe` [list2pat [+                ("family", [(Strong, ValueString "OpenSans")])+              ]]+            tRule "@font-face {font-family: 'Open Sans'}" `shouldBe` [list2pat [+                ("family", [(Strong, ValueString "Open Sans")])+              ]]++            tRule "@font-face {font-stretch: condensed}" `shouldBe` [list2pat [+                ("width", [(Strong, ValueInt 75)])+              ]]+            tRule "@font-face {font-stretch: expanded}" `shouldBe` [list2pat [+                ("width", [(Strong, ValueInt 125)])+              ]]+            tRule "@font-face {font-stretch: ultra-expanded}" `shouldBe` [list2pat [+                ("width", [(Strong, ValueInt 200)])+              ]]+            tRule "@font-face {font-stretch: 50%}" `shouldBe` [list2pat [+                ("width", [(Strong, ValueInt 50)])+              ]]+            tRule "@font-face {font-stretch: 100%}" `shouldBe` [list2pat [+                ("width", [(Strong, ValueInt 100)])+              ]]+            tRule "@font-face {font-stretch: 150%}" `shouldBe` [list2pat [+                ("width", [(Strong, ValueInt 150)])+              ]]++            tRule "@font-face {font-weight: normal}" `shouldBe` [list2pat [+                ("weight", [(Strong, ValueInt 80)])+              ]]+            tRule "@font-face {font-weight: bold}" `shouldBe` [list2pat [+                ("weight", [(Strong, ValueInt 200)])+              ]]+            tRule "@font-face {font-weight: 100}" `shouldBe` [list2pat [+                ("weight", [(Strong, ValueInt 0)])+              ]]+            tRule "@font-face {font-weight: 900}" `shouldBe` [list2pat [+                ("weight", [(Strong, ValueInt 210)])+              ]]++            tRule "@font-face {font-feature-settings: normal}" `shouldBe` [list2pat []]+            tRule "@font-face {font-feature-settings: \"liga\" 0}" `shouldBe` [list2pat [+                ("fontfeatures", [(Strong, ValueString "liga")])+              ]]+            tRule "@font-face {font-feature-settings: \"tnum\"}" `shouldBe` [list2pat [+                ("fontfeatures", [(Strong, ValueString "tnum")])+              ]]+            tRule "@font-face {font-feature-settings: \"smcp\", \"zero\"}" `shouldBe` [list2pat [+                ("fontfeatures", [+                    (Strong, ValueString "smcp,zero") -- Is this right?+                ])+              ]]++            tRule "@font-face {font-variation-settings: 'wght' 50}" `shouldBe` [list2pat [+                ("variable", [(Strong, ValueBool True)])+              ]]+            tRule "@font-face {font-variation-settings: 'wght' 850}" `shouldBe` [list2pat [+                ("variable", [(Strong, ValueBool True)])+              ]]+            tRule "@font-face {font-variation-settings: 'wdth' 25}" `shouldBe` [list2pat [+                ("variable", [(Strong, ValueBool True)])+              ]]+            tRule "@font-face {font-variation-settings: 'wdth' 75}" `shouldBe` [list2pat [+                ("variable", [(Strong, ValueBool True)])+              ]]++            tRule "@font-face {unicode-range: U+26}" `shouldBe` [list2pat [+                ("charset", [(Strong, ValueCharSet $ IS.fromList [0x26])])+              ]]+            tRule "@font-face {unicode-range: U+0-7F}" `shouldBe` [list2pat [+                ("charset", [(Strong, ValueCharSet $ IS.fromList [0..0x7f])])+              ]]+            tRule "@font-face {unicode-range: U+0025-00FF}" `shouldBe` [list2pat [+                ("charset", [(Strong, ValueCharSet $ IS.fromList [0x25..0xff])])+              ]]+            tRule "@font-face {unicode-range: U+4??}" `shouldBe` [list2pat [+                ("charset", [(Strong, ValueCharSet $ IS.fromList [0x400..0x4ff])])+              ]]+            tRule "@font-face {unicode-range: U+0025-00FF, U+4??}" `shouldBe` [list2pat [+                ("charset", [(Strong, ValueCharSet $ IS.fromList ([0x25..0xff] ++ [0x400..0x4ff]))])+              ]]++            tRule' [+                "@font-face {",+                "  font-family: \"Trickster\";",+                "  src:",+                "    local(\"Trickster\"),",+                "    url(\"trickster-COLRv1.otf\") format(\"opentype\") tech(color-COLRv1),",+                "    url(\"trickster-outline.otf\") format(\"opentype\"),",+                "    url(\"trickster-outline.woff\") format(\"woff\");",+                "}"+              ] `shouldBe` [list2pat [+                  ("family", [(Strong, ValueString "Trickster")]),+                  ("web-src", [(Strong, ValueString "local:Trickster"),+                        (Strong, ValueString "trickster-COLRv1.otf"),+                        (Strong, ValueString "trickster-outline.otf"),+                        (Strong, ValueString "trickster-outline.woff")])+              ]]
− test/Test.hs 
@@ -1,32 +0,0 @@-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...