diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,10 @@ # 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 * First version. Released on an unsuspecting world. diff --git a/Graphics/Text/Font/Choose.hs b/Graphics/Text/Font/Choose.hs --- a/Graphics/Text/Font/Choose.hs +++ b/Graphics/Text/Font/Choose.hs @@ -1,5 +1,5 @@ -module Graphics.Text.Font.Choose(CharSet, FontSet, ObjectSet, Pattern(..), Binding(..), - Range(..), iRange, StrSet, StrList, Value(..), FontFaceParser(..), +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, @@ -26,6 +26,7 @@ ) 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, diff --git a/Graphics/Text/Font/Choose/CharSet.hs b/Graphics/Text/Font/Choose/CharSet.hs --- a/Graphics/Text/Font/Choose/CharSet.hs +++ b/Graphics/Text/Font/Choose/CharSet.hs @@ -1,11 +1,13 @@ module Graphics.Text.Font.Choose.CharSet where -import Data.Set (Set, union) -import qualified Data.Set as Set +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 Control.Monad (forM) import Foreign.Marshal.Alloc (alloca) @@ -15,29 +17,33 @@ import Numeric (readHex) -- | An FcCharSet is a set of Unicode chars. -type CharSet = Set Char +type CharSet = IntSet -parseChar :: String -> Char +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 $ Set.union set $ Set.fromList [parseChar start..parseChar end] + Just $ union set $ IntSet.fromList [parseChar start..parseChar end] | (codepoint@(_:_), rest) <- span isHexDigit cs, Just set <- parseCharSet' rest = - Just $ flip Set.insert set $ parseChar codepoint + Just $ flip IntSet.insert set $ parseChar codepoint | (codepoint@(_:_), rest) <- span (\c -> isHexDigit c || c == '?') cs, Just set <- parseCharSet' rest = - Just $ Set.union set $ Set.fromList [ + Just $ IntSet.union set $ IntSet.fromList [ parseWild '0' codepoint..parseWild 'f' codepoint] parseCharSet _ = Nothing +parseCharSet' :: String -> Maybe CharSet parseCharSet' (',':rest) = parseCharSet rest -parseCharSet' "" = Just Set.empty +parseCharSet' "" = Just IntSet.empty parseCharSet' _ = Nothing ------ @@ -54,30 +60,36 @@ withCharSet :: CharSet -> (CharSet_ -> IO a) -> IO a withCharSet chars cb = withNewCharSet $ \chars' -> do - forM (Set.elems chars) $ \ch' -> - throwFalse <$> (fcCharSetAddChar chars' $ fromIntegral $ ord ch') + 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 Set.empty - | otherwise = allocaArray fcCHARSET_MAP_SIZE $ \iter' -> alloca $ \next' -> do - first <- fcCharSetFirstPage chars' iter' next' - let go = do - ch <- fcCharSetNextPage chars' iter' next' - if ch == maxBound then return [] - else do - chs <- go - return (ch:chs) - if first == maxBound then return Set.empty else do - rest <- go - return $ Set.fromList $ map (unsafeChr . fromIntegral) (first:rest) -foreign import ccall "my_FcCharSetFirstPage" fcCharSetFirstPage :: - CharSet_ -> Ptr Word32 -> Ptr Word32 -> IO Word32 -foreign import ccall "my_FcCharSetNextPage" fcCharSetNextPage :: - CharSet_ -> Ptr Word32 -> Ptr Word32 -> IO Word32 -foreign import ccall "my_FcCHARSET_MAP_SIZE" fcCHARSET_MAP_SIZE :: Int + | 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 diff --git a/cbits/charsetiter.c b/cbits/charsetiter.c new file mode 100644 --- /dev/null +++ b/cbits/charsetiter.c @@ -0,0 +1,31 @@ +#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/pattern.c b/cbits/pattern.c --- a/cbits/pattern.c +++ b/cbits/pattern.c @@ -1,17 +1,6 @@ #include #include -int my_FcCHARSET_MAP_SIZE() { - return FC_CHARSET_MAP_SIZE; -} - -FcChar32 my_FcCharSetFirstPage(const FcCharSet *a, FcChar32 *map, FcChar32 *next) { - return FcCharSetFirstPage(a, map, next); -} -FcChar32 my_FcCharSetNextPage(const FcCharSet *a, FcChar32 *map, FcChar32 *next) { - return FcCharSetNextPage(a, map, next); -} - FcBool my_FcPatternAdd(FcPattern *p, const char *object, FcBool binding, FcBool append, FcValue *value) { if (binding) { diff --git a/fontconfig-pure.cabal b/fontconfig-pure.cabal --- a/fontconfig-pure.cabal +++ b/fontconfig-pure.cabal @@ -10,7 +10,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.2.0.1 +version: 0.3.0.0 -- A short (one-line) description of the package. synopsis: Pure-functional language bindings to FontConfig @@ -62,7 +62,7 @@ Graphics.Text.Font.Choose.Config, Graphics.Text.Font.Choose.Init, Graphics.Text.Font.Choose.Weight - c-sources: cbits/pattern.c + c-sources: cbits/pattern.c, cbits/charsetiter.c -- LANGUAGE extensions used by modules in this package. -- other-extensions: