From 7b41b9f8208081ab1f6eb80b36a7e135bd190aa2 Mon Sep 17 00:00:00 2001
From: Adrian Cochrane <adrian@openwork.nz>
Date: Fri, 18 Nov 2022 15:27:44 +1300
Subject: [PATCH] Correct memory management for FcLangSet.

---
 Graphics/Text/Font/Choose/LangSet.hs | 41 ++++++++++++++++++++++------
 Graphics/Text/Font/Choose/Strings.hs |  6 +++-
 2 files changed, 37 insertions(+), 10 deletions(-)

diff --git a/Graphics/Text/Font/Choose/LangSet.hs b/Graphics/Text/Font/Choose/LangSet.hs
index 018ce94..9e1a608 100644
--- a/Graphics/Text/Font/Choose/LangSet.hs
+++ b/Graphics/Text/Font/Choose/LangSet.hs
@@ -1,12 +1,16 @@
-module Graphics.Text.Font.Choose.LangSet where
+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, StrSet_)
+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)
@@ -18,22 +22,40 @@ defaultLangs = thawStrSet =<< fcGetDefaultLangs
 foreign import ccall "FcGetDefaultLangs" fcGetDefaultLangs :: IO StrSet_
 
 langs :: LangSet
-langs = unsafePerformIO (thawStrSet =<< fcGetLangs)
+langs = unsafePerformIO $ thawStrSet_ $ fcGetLangs
 foreign import ccall "FcGetLangs" fcGetLangs :: IO StrSet_
 
-data LangResult = SameLang | DifferentTerritory | DifferentLang deriving Enum
+data LangResult = SameLang | DifferentTerritory | DifferentLang
+    deriving (Enum, Eq, Read, Show)
 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 :: LangSet -> LangSet -> Bool
+langSetContains a b = unsafePerformIO $ withLangSet a $ \a' -> withLangSet b $
+    fcLangSetContains a'
+foreign import ccall "FcLangSetContains" fcLangSetContains ::
+    LangSet_ -> LangSet_ -> IO Bool
+
+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
+
 langNormalize :: String -> String
-langNormalize lang = unsafePerformIO $ withCString lang (peekCString . fcLangNormalize)
+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
 
 langCharSet :: String -> CharSet
-langCharSet lang = unsafePerformIO $ withCString lang (thawCharSet . fcLangGetCharSet)
+langCharSet lang = unsafePerformIO $
+    withCString lang (thawCharSet . throwNull . fcLangGetCharSet)
 foreign import ccall "FcLangGetCharSet" fcLangGetCharSet :: CString -> CharSet_
 
 ------
@@ -44,16 +66,17 @@ data LangSet'
 type LangSet_ = Ptr LangSet'
 
 withNewLangSet :: (LangSet_ -> IO a) -> IO a
-withNewLangSet = bracket fcLangSetCreate fcLangSetDestroy
+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 $ fcLangSetAdd langs'
+    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 langs' = thawStrSet =<< fcLangSetGetLangs langs'
+thawLangSet = thawStrSet_ . fcLangSetGetLangs
 foreign import ccall "FcLangSetGetLangs" fcLangSetGetLangs :: LangSet_ -> IO StrSet_
diff --git a/Graphics/Text/Font/Choose/Strings.hs b/Graphics/Text/Font/Choose/Strings.hs
index b64f3e7..b6dac5e 100644
--- a/Graphics/Text/Font/Choose/Strings.hs
+++ b/Graphics/Text/Font/Choose/Strings.hs
@@ -1,8 +1,9 @@
 module Graphics.Text.Font.Choose.Strings (StrSet, StrSet_, StrList, StrList_,
-    withStrSet, withFilenameSet, thawStrSet, withStrList, thawStrList) where
+    withStrSet, withFilenameSet, thawStrSet, thawStrSet_, withStrList, thawStrList) where
 
 import Data.Set (Set)
 import qualified Data.Set as Set
+import Graphics.Text.Font.Choose.Result (throwNull)
 
 import Foreign.Ptr (Ptr, nullPtr)
 import Foreign.C.String (CString, withCString, peekCString)
@@ -35,6 +36,9 @@ foreign import ccall "FcStrSetAddFilename" fcStrSetAddFilename ::
 thawStrSet :: StrSet_ -> IO StrSet
 thawStrSet strs = Set.fromList <$> withStrList strs thawStrList
 
+thawStrSet_ :: IO StrSet_ -> IO StrSet
+thawStrSet_ cb = bracket (throwNull <$> cb) fcStrSetDestroy thawStrSet
+
 ------------
 
 type StrList = [String]
-- 
2.30.2