From 160a3581125528284fb086f831e1d91815766d2b Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Thu, 17 Nov 2022 15:55:49 +1300 Subject: [PATCH] Refine memory management for Patterns. --- Graphics/Text/Font/Choose/Pattern.hs | 54 ++++++++++++++-------------- Graphics/Text/Font/Choose/Result.hs | 3 +- 2 files changed, 30 insertions(+), 27 deletions(-) diff --git a/Graphics/Text/Font/Choose/Pattern.hs b/Graphics/Text/Font/Choose/Pattern.hs index 559dc05..bb6f9f7 100644 --- a/Graphics/Text/Font/Choose/Pattern.hs +++ b/Graphics/Text/Font/Choose/Pattern.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 () diff --git a/Graphics/Text/Font/Choose/Result.hs b/Graphics/Text/Font/Choose/Result.hs index dda0344..5ad13f0 100644 --- a/Graphics/Text/Font/Choose/Result.hs +++ b/Graphics/Text/Font/Choose/Result.hs @@ -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) -- 2.30.2