7 files changed, 79 insertions(+), 54 deletions(-)

M CHANGELOG.md
M Graphics/Text/Font/Choose.hs
M Graphics/Text/Font/Choose/CharSet.hs
M Graphics/Text/Font/Choose/FontSet.hs
M Graphics/Text/Font/Choose/Pattern.hs
M cbits/pattern.c
M fontconfig-pure.cabal

@@ 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.

@@ 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 @@ module Graphics.Text.Font.Choose(CharSet, FontSet, ObjectSet, Pattern(..), Bindi
     ) 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,

@@ 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 Data.Char (ord, isHexDigit)
 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 @@ foreign import ccall "FcCharSetDestroy" fcCharSetDestroy :: CharSet_ -> IO ()
 
 withCharSet :: CharSet -> (CharSet_ -> IO a) -> IO a
 withCharSet chars cb = withNewCharSet $ \chars' -> do
-    forM (Set.elems chars) $ \ch' ->
-        throwFalse <$> (fcCharSetAddChar chars' $ fromIntegral $ ord ch')
+    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

@@ 10,6 10,7 @@ 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)


@@ 58,7 59,11 @@ 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)
+        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_
 

@@ 2,6 2,7 @@
 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,


@@ 16,12 17,14 @@ import Data.Hashable (Hashable(..))
 import GHC.Generics (Generic)
 import Graphics.Text.Font.Choose.Result (throwFalse, throwNull, throwInt)
 
-import Foreign.Ptr (Ptr)
+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)
+import System.IO.Unsafe (unsafePerformIO, unsafeInterleaveIO)
 
 import Control.Monad (forM, join)
 import Data.Maybe (catMaybes, fromMaybe, mapMaybe)


@@ 160,20 163,23 @@ data PatternIter'
 type PatternIter_ = Ptr PatternIter'
 foreign import ccall "size_PatternIter" patIter'Size :: Int
 thawPattern :: Pattern_ -> IO Pattern
-thawPattern pat' = allocaBytes patIter'Size $ \iter' -> do
-    fcPatternIterStart pat' iter'
-    ret <- go iter'
+thawPattern pat' = do
+    iter <- mallocForeignPtrBytes patIter'Size
+    pat <- gcPattern pat'
+    with2ForeignPtrs pat iter fcPatternIterStart
+    ret <- go pat iter
     return $ normalizePattern ret
   where
-    go :: PatternIter_ -> IO Pattern
-    go iter' = do
-        ok <- fcPatternIterIsValid pat' iter'
+    go :: ForeignPtr Pattern' -> ForeignPtr PatternIter' -> IO Pattern
+    go pat iter = unsafeInterleaveIO $ do
+        ok <- with2ForeignPtrs pat iter fcPatternIterIsValid
         if ok then do
-            x <- thawPattern' pat' iter'
-            ok' <- fcPatternIterNext pat' iter'
-            xs <- if ok' then go iter' else return []
+            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 ::


@@ 208,6 214,13 @@ 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

@@ 1,17 1,6 @@
 #include <fontconfig/fontconfig.h>
 #include <stddef.h>
 
-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) {

@@ 10,7 10,7 @@ name:                fontconfig-pure
 -- PVP summary:      +-+------- breaking API changes
 --                   | | +----- non-breaking API additions
 --                   | | | +--- code changes with no API change
-version:             0.2.0.0
+version:             0.3.0.0
 
 -- A short (one-line) description of the package.
 synopsis:            Pure-functional language bindings to FontConfig


@@ 62,7 62,7 @@ library
                 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: