2 files changed, 30 insertions(+), 27 deletions(-)

M Graphics/Text/Font/Choose/Pattern.hs
M Graphics/Text/Font/Choose/Result.hs

@@ 9,15 9,16 @@ import Graphics.Text.Font.Choose.Value (Value, withValue, thawValue, Value_, val
 import Graphics.Text.Font.Choose.ObjectSet (ObjectSet, ObjectSet_, withObjectSet)
 import Data.Hashable (Hashable(..))
 import GHC.Generics (Generic)
+import Graphics.Text.Font.Choose.Result (throwFalse, throwNull, throwInt)
 
 import Foreign.Ptr (Ptr)
-import Foreign.Marshal.Alloc (alloca, allocaBytes)
+import Foreign.Marshal.Alloc (alloca, allocaBytes, free)
 import Foreign.Storable (Storable(..))
 import Foreign.C.String (CString, withCString, peekCString)
 import Debug.Trace (trace) -- For reporting internal errors!
 import System.IO.Unsafe (unsafePerformIO)
 
-import Control.Monad (forM)
+import Control.Monad (forM, join)
 import Data.Maybe (catMaybes)
 import Control.Exception (bracket)
 


@@ 41,9 42,8 @@ foreign import ccall "FcPatternEqualSubset" fcPatternEqualSubset ::
 
 filter :: Pattern -> ObjectSet -> Pattern
 filter pat objs =
-    unsafePerformIO $ withPattern pat $ \pat' -> withObjectSet objs $ \objs' -> do
-        ret <- fcPatternFilter pat' objs'
-        thawPattern ret
+    unsafePerformIO $ withPattern pat $ \pat' -> withObjectSet objs $ \objs' ->
+        thawPattern_ $ fcPatternFilter pat' objs'
 foreign import ccall "FcPatternFilter" fcPatternFilter ::
     Pattern_ -> ObjectSet_ -> IO Pattern_
 


@@ 53,23 53,21 @@ substitute pat = unsafePerformIO $ withPattern pat $ \pat' -> do
     thawPattern pat'
 foreign import ccall "FcDefaultSubstitute" fcDefaultSubstitute :: Pattern_ -> IO ()
 
+-- Is this correct memory management?
 nameParse :: String -> Pattern
-nameParse name = unsafePerformIO $ withCString name $ \name' -> do
-    ret <- fcNameParse name'
-    thawPattern ret
+nameParse name = unsafePerformIO $ withCString name $ \name' ->
+    thawPattern_ $ fcNameParse name'
 foreign import ccall "FcNameParse" fcNameParse :: CString -> IO Pattern_
 
 nameUnparse :: Pattern -> String
-nameUnparse pat = unsafePerformIO $ withPattern pat $ \pat' -> do
-    ret <- fcNameUnparse pat'
-    peekCString ret
+nameUnparse pat = unsafePerformIO $ withPattern pat $ \pat' ->
+    bracket (throwNull <$> fcNameUnparse pat') free peekCString
 foreign import ccall "FcNameUnparse" fcNameUnparse :: Pattern_ -> IO CString
 
 format :: Pattern -> String -> String
 format pat fmt =
     unsafePerformIO $ withPattern pat $ \pat' -> withCString fmt $ \fmt' -> do
-        ret <- fcPatternFormat pat' fmt'
-        peekCString ret
+        bracket (throwNull <$> fcPatternFormat pat' fmt') free peekCString
 foreign import ccall "FcPatternFormat" fcPatternFormat ::
     Pattern_ -> CString -> IO CString
 


@@ 83,16 81,18 @@ 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) -> withValue val $
-            fcPatternAdd_ pat' obj' (strength == Strong) True
+        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 fcPatternCopy
-foreign import ccall "FcPatternCopy" fcPatternCopy :: 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'


@@ 105,35 105,35 @@ thawPattern pat' = allocaBytes patIter'Size $ \iter' -> do
   where
     go :: PatternIter_ -> IO Pattern
     go iter' = do
-        ok <- fcPatternIterNext pat' iter'
+        ok <- fcPatternIterIsValid pat' iter'
         if ok then do
             x <- thawPattern' pat' iter'
+            ok' <- fcPatternIterNext pat' iter'
+            xs <- if ok' then go iter' else return []
             xs <- go iter'
             return (x : xs)
         else return []
 foreign import ccall "FcPatternIterStart" fcPatternIterStart ::
     Pattern_ -> PatternIter_ -> IO ()
+foreign import ccall "FcPatternIterIsValid" fcPatternIterIsValid ::
+    Pattern_ -> PatternIter_ -> IO Bool
 foreign import ccall "FcPatternIterNext" fcPatternIterNext ::
     Pattern_ -> PatternIter_ -> IO Bool
 
 thawPattern' :: Pattern_ -> PatternIter_ -> IO (String, [(Binding, Value)])
 thawPattern' pat' iter' = do
-    obj <- peekCString =<< fcPatternIterGetObject pat' iter'
+    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'
-            if res == 0 then do
+            throwInt res $ do
                 binding <- peek binding'
                 val' <- thawValue val'
                 return $ case val' of
                     Just val -> Just (toEnum binding, val)
                     Nothing -> Nothing
-            else trace
-                    ("FontConfig: Error retrieving value for " ++ obj ++
-                        " code: " ++ show res) $
-                return Nothing
-    return (obj, catMaybes values)
+    return (obj, catMaybes $ map join values)
 foreign import ccall "FcPatternIterGetObject" fcPatternIterGetObject ::
     Pattern_ -> PatternIter_ -> IO CString
 foreign import ccall "FcPatternIterValueCount" fcPatternIterValueCount ::


@@ 141,6 141,8 @@ foreign import ccall "FcPatternIterValueCount" fcPatternIterValueCount ::
 foreign import ccall "FcPatternIterGetValue" fcPatternIterGetValue ::
     Pattern_ -> PatternIter_ -> Int -> Value_ -> Ptr Int -> IO Int
 
-withNewPattern cb = bracket fcPatternCreate fcPatternDestroy cb
+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 ()

@@ 1,4 1,5 @@
-module Graphics.Text.Font.Choose.Result (Result(..), resultFromPointer) where
+module Graphics.Text.Font.Choose.Result (Result(..), resultFromPointer,
+    Error(..), throwResult, throwInt, throwPtr, throwFalse, throwNull) where
 
 import Foreign.Storable (peek)
 import Foreign.Ptr (Ptr, nullPtr)