diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,10 +1,5 @@ # Revision history for fontconfig-pure -## 0.3.0.0 -- 2023-10-01 - -* Addressing segfaults & mainloops. -* Switched underlying CharSet collection to IntSet for efficiency. - -## 0.1.0.0 -- YYYY-mm-dd +## 0.5 -- YYYY-mm-dd * First version. Released on an unsuspecting world. diff --git a/FreeType/FontConfig.hs b/FreeType/FontConfig.hs deleted file mode 100644 --- a/FreeType/FontConfig.hs +++ /dev/null @@ -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 diff --git a/Graphics/Text/Font/Choose.hs b/Graphics/Text/Font/Choose.hs deleted file mode 100644 --- a/Graphics/Text/Font/Choose.hs +++ /dev/null @@ -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) diff --git a/Graphics/Text/Font/Choose/CharSet.hs b/Graphics/Text/Font/Choose/CharSet.hs deleted file mode 100644 --- a/Graphics/Text/Font/Choose/CharSet.hs +++ /dev/null @@ -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 diff --git a/Graphics/Text/Font/Choose/Config.hs b/Graphics/Text/Font/Choose/Config.hs deleted file mode 100644 --- a/Graphics/Text/Font/Choose/Config.hs +++ /dev/null @@ -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 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 diff --git a/Graphics/Text/Font/Choose/FontSet.hs b/Graphics/Text/Font/Choose/FontSet.hs deleted file mode 100644 --- a/Graphics/Text/Font/Choose/FontSet.hs +++ /dev/null @@ -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) diff --git a/Graphics/Text/Font/Choose/FontSet/API.hs b/Graphics/Text/Font/Choose/FontSet/API.hs deleted file mode 100644 --- a/Graphics/Text/Font/Choose/FontSet/API.hs +++ /dev/null @@ -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_ diff --git a/Graphics/Text/Font/Choose/Init.hs b/Graphics/Text/Font/Choose/Init.hs deleted file mode 100644 --- a/Graphics/Text/Font/Choose/Init.hs +++ /dev/null @@ -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 diff --git a/Graphics/Text/Font/Choose/LangSet.hs b/Graphics/Text/Font/Choose/LangSet.hs deleted file mode 100644 --- a/Graphics/Text/Font/Choose/LangSet.hs +++ /dev/null @@ -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_ diff --git a/Graphics/Text/Font/Choose/ObjectSet.hs b/Graphics/Text/Font/Choose/ObjectSet.hs deleted file mode 100644 --- a/Graphics/Text/Font/Choose/ObjectSet.hs +++ /dev/null @@ -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 () diff --git a/Graphics/Text/Font/Choose/Pattern.hs b/Graphics/Text/Font/Choose/Pattern.hs deleted file mode 100644 --- a/Graphics/Text/Font/Choose/Pattern.hs +++ /dev/null @@ -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 diff --git a/Graphics/Text/Font/Choose/Range.hs b/Graphics/Text/Font/Choose/Range.hs deleted file mode 100644 --- a/Graphics/Text/Font/Choose/Range.hs +++ /dev/null @@ -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 diff --git a/Graphics/Text/Font/Choose/Result.hs b/Graphics/Text/Font/Choose/Result.hs deleted file mode 100644 --- a/Graphics/Text/Font/Choose/Result.hs +++ /dev/null @@ -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 diff --git a/Graphics/Text/Font/Choose/Strings.hs b/Graphics/Text/Font/Choose/Strings.hs deleted file mode 100644 --- a/Graphics/Text/Font/Choose/Strings.hs +++ /dev/null @@ -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 diff --git a/Graphics/Text/Font/Choose/Value.hs b/Graphics/Text/Font/Choose/Value.hs deleted file mode 100644 --- a/Graphics/Text/Font/Choose/Value.hs +++ /dev/null @@ -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 diff --git a/Graphics/Text/Font/Choose/Weight.hs b/Graphics/Text/Font/Choose/Weight.hs deleted file mode 100644 --- a/Graphics/Text/Font/Choose/Weight.hs +++ /dev/null @@ -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 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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 diff --git a/Main.hs b/Main.hs deleted file mode 100644 --- a/Main.hs +++ /dev/null @@ -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!" diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,6 @@ +module Main where + + +main :: IO () +main = do + putStrLn "Hello, Haskell!" diff --git a/cbits/charsetiter.c b/cbits/charsetiter.c deleted file mode 100644 --- a/cbits/charsetiter.c +++ /dev/null @@ -1,31 +0,0 @@ -#include -#include - -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; -} diff --git a/cbits/cmp.c b/cbits/cmp.c new file mode 100644 --- /dev/null +++ b/cbits/cmp.c @@ -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: */ + diff --git a/cbits/fontconfig-wrap.c b/cbits/fontconfig-wrap.c new file mode 100644 --- /dev/null +++ b/cbits/fontconfig-wrap.c @@ -0,0 +1,722 @@ +#include "transcode.h" +#include +#include +#include + +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; +}*/ diff --git a/cbits/pattern.c b/cbits/pattern.c deleted file mode 100644 --- a/cbits/pattern.c +++ /dev/null @@ -1,37 +0,0 @@ -#include -#include - -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]; -} diff --git a/cbits/transcode.c b/cbits/transcode.c new file mode 100644 --- /dev/null +++ b/cbits/transcode.c @@ -0,0 +1,766 @@ +#include "cmp.h" +#include +#include +#include +#include +#include + +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")); + } +} diff --git a/fontconfig-pure.cabal b/fontconfig-pure.cabal --- a/fontconfig-pure.cabal +++ b/fontconfig-pure.cabal @@ -1,109 +1,150 @@ --- 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.0.0 -- A short (one-line) description of the package. -synopsis: Pure-functional language bindings to FontConfig +synopsis: + Resolves font descriptions to font libraries, including ones installed on your freedesktop (Linux or BSD system). -- 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). -- 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@argonaut-constellation.org -- A copyright notice. -- copyright: - -category: Text - -build-type: Simple +category: Text +build-type: Simple --- Extra files to be distributed with the package, such as examples or a --- README. -extra-source-files: CHANGELOG.md +-- Extra doc files to be distributed with the package, such as a CHANGELOG or a README. +extra-doc-files: CHANGELOG.md --- Constraint on the version of Cabal needed to build this package. -cabal-version: >=1.10 +-- Extra source files to be distributed with the package, such as examples, or a tutorial module. +-- extra-source-files: +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/transcode.c, cbits/fontconfig-wrap.c + 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, stylist-traits >=0.1.1 && <1, text, msgpack >= 1.0 && <2, + vector >= 0.13 && <1, bytestring, stylist-traits, css-syntax, + QuickCheck - -- 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 diff --git a/lib/FreeType/FontConfig.hs b/lib/FreeType/FontConfig.hs new file mode 100644 --- /dev/null +++ b/lib/FreeType/FontConfig.hs @@ -0,0 +1,375 @@ +{-# 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' + } + +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 diff --git a/lib/Graphics/Text/Font/Choose.hs b/lib/Graphics/Text/Font/Choose.hs new file mode 100644 --- /dev/null +++ b/lib/Graphics/Text/Font/Choose.hs @@ -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 diff --git a/lib/Graphics/Text/Font/Choose/CharSet.hs b/lib/Graphics/Text/Font/Choose/CharSet.hs new file mode 100644 --- /dev/null +++ b/lib/Graphics/Text/Font/Choose/CharSet.hs @@ -0,0 +1,69 @@ +-- | 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 _ [] = [] + +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) diff --git a/lib/Graphics/Text/Font/Choose/Config.hs b/lib/Graphics/Text/Font/Choose/Config.hs new file mode 100644 --- /dev/null +++ b/lib/Graphics/Text/Font/Choose/Config.hs @@ -0,0 +1,55 @@ +{-# 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 +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 diff --git a/lib/Graphics/Text/Font/Choose/Config/Accessors.hs b/lib/Graphics/Text/Font/Choose/Config/Accessors.hs new file mode 100644 --- /dev/null +++ b/lib/Graphics/Text/Font/Choose/Config/Accessors.hs @@ -0,0 +1,261 @@ +{-# 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, 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) + +-- | 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. +current :: IO Config +current = newForeignPtr fcConfigDestroy =<< throwNull =<< fcConfigReference nullPtr +foreign import capi "fontconfig/fontconfig.h FcConfigReference" fcConfigReference :: Ptr Config' -> IO (Ptr Config') + +-- | 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 <test> 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 diff --git a/lib/Graphics/Text/Font/Choose/FontSet.hs b/lib/Graphics/Text/Font/Choose/FontSet.hs new file mode 100644 --- /dev/null +++ b/lib/Graphics/Text/Font/Choose/FontSet.hs @@ -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) diff --git a/lib/Graphics/Text/Font/Choose/Internal/FFI.hs b/lib/Graphics/Text/Font/Choose/Internal/FFI.hs new file mode 100644 --- /dev/null +++ b/lib/Graphics/Text/Font/Choose/Internal/FFI.hs @@ -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) diff --git a/lib/Graphics/Text/Font/Choose/Internal/Test.hs b/lib/Graphics/Text/Font/Choose/Internal/Test.hs new file mode 100644 --- /dev/null +++ b/lib/Graphics/Text/Font/Choose/Internal/Test.hs @@ -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 diff --git a/lib/Graphics/Text/Font/Choose/LangSet.hs b/lib/Graphics/Text/Font/Choose/LangSet.hs new file mode 100644 --- /dev/null +++ b/lib/Graphics/Text/Font/Choose/LangSet.hs @@ -0,0 +1,104 @@ +{-# 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 + +-- | Compares language coverage for the 2 given LangSets. +cmp' :: LangSet' -> LangSet' -> LangComparison +cmp' a b | valid a && valid b = i2cmp $ withMessage fcLangSetCompare [a, b] + | otherwise = DifferentLang + where valid = validLangSet' +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 diff --git a/lib/Graphics/Text/Font/Choose/ObjectSet.hs b/lib/Graphics/Text/Font/Choose/ObjectSet.hs new file mode 100644 --- /dev/null +++ b/lib/Graphics/Text/Font/Choose/ObjectSet.hs @@ -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! diff --git a/lib/Graphics/Text/Font/Choose/Pattern.hs b/lib/Graphics/Text/Font/Choose/Pattern.hs new file mode 100644 --- /dev/null +++ b/lib/Graphics/Text/Font/Choose/Pattern.hs @@ -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 = [] diff --git a/lib/Graphics/Text/Font/Choose/Range.hs b/lib/Graphics/Text/Font/Choose/Range.hs new file mode 100644 --- /dev/null +++ b/lib/Graphics/Text/Font/Choose/Range.hs @@ -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 diff --git a/lib/Graphics/Text/Font/Choose/Result.hs b/lib/Graphics/Text/Font/Choose/Result.hs new file mode 100644 --- /dev/null +++ b/lib/Graphics/Text/Font/Choose/Result.hs @@ -0,0 +1,21 @@ +-- | 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) + +data FcException = ErrType | ErrNoId | ErrOOM | ErrOther deriving (Read, Show, Eq, Enum) +instance Exception FcException + +throwBool :: Bool -> IO () +throwBool False = throwIO ErrOOM +throwBool True = return () + +throwNull :: Ptr a -> IO (Ptr a) +throwNull a | a == nullPtr = throwIO ErrOOM + | otherwise = return a + +throwString :: String -> IO () +throwString a | Just b <- readMaybe a :: Maybe FcException = throwIO b + | otherwise = return () diff --git a/lib/Graphics/Text/Font/Choose/StrSet.hs b/lib/Graphics/Text/Font/Choose/StrSet.hs new file mode 100644 --- /dev/null +++ b/lib/Graphics/Text/Font/Choose/StrSet.hs @@ -0,0 +1,19 @@ +-- | 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(..)) + +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 + +validStrSet :: StrSet -> Bool +validStrSet (StrSet self) = notElem '\0' `all` self diff --git a/lib/Graphics/Text/Font/Choose/Value.hs b/lib/Graphics/Text/Font/Choose/Value.hs new file mode 100644 --- /dev/null +++ b/lib/Graphics/Text/Font/Choose/Value.hs @@ -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 diff --git a/lib/Graphics/Text/Font/Choose/Weight.hs b/lib/Graphics/Text/Font/Choose/Weight.hs new file mode 100644 --- /dev/null +++ b/lib/Graphics/Text/Font/Choose/Weight.hs @@ -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 diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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 [ + ("width", [(Strong, ValueInt 100)]) + ] + 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")]) + ]] diff --git a/test/Test.hs b/test/Test.hs deleted file mode 100644 --- a/test/Test.hs +++ /dev/null @@ -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...