From b4f50b899d7bdc31953ee467b88ba795596635d1 Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Mon, 21 Nov 2022 21:43:15 +1300 Subject: [PATCH] Correct FcConfig memory handling & exception throwing. --- Graphics/Text/Font/Choose/Config.hs | 73 +++++++++++++++-------------- 1 file changed, 38 insertions(+), 35 deletions(-) diff --git a/Graphics/Text/Font/Choose/Config.hs b/Graphics/Text/Font/Choose/Config.hs index af3ca0f..9a4961e 100644 --- a/Graphics/Text/Font/Choose/Config.hs +++ b/Graphics/Text/Font/Choose/Config.hs @@ -5,15 +5,17 @@ import Graphics.Text.Font.Choose.FontSet import Graphics.Text.Font.Choose.CharSet import Graphics.Text.Font.Choose.Pattern import Graphics.Text.Font.Choose.ObjectSet -import Graphics.Text.Font.Choose.Result (throwNull, throwFalse) import Foreign.ForeignPtr import Foreign.Ptr (Ptr, nullPtr, FunPtr) -import Foreign.Marshal.Alloc (alloca, allocaBytes) +import Foreign.Marshal.Alloc (alloca, allocaBytes, free) import Foreign.Storable (Storable(..)) import Foreign.C.String (CString, peekCString, withCString) import System.IO.Unsafe (unsafePerformIO) +import Control.Exception (bracket) +import Graphics.Text.Font.Choose.Result (throwNull, throwFalse, throwPtr) + type Config = ForeignPtr Config' data Config' type Config_ = Ptr Config' @@ -110,44 +112,48 @@ configAppFontAddFile' file = foreign import ccall "FcConfigAppFontAddFile" fcConfigAppFontAddFile :: Config_ -> CString -> IO Bool -configAppFontAddDir :: Config -> String -> IO Bool -configAppFontAddDir config file = - withForeignPtr config $ \config' -> withCString file $ fcConfigAppFontAddDir config' -configAppFontAddDir' :: String -> IO Bool -configAppFontAddDir' = flip withCString $ fcConfigAppFontAddDir nullPtr +configAppFontAddDir :: Config -> String -> IO () +configAppFontAddDir config file = throwFalse =<< + (withForeignPtr config $ \config' -> withCString file $ fcConfigAppFontAddDir config') +configAppFontAddDir' :: String -> IO () +configAppFontAddDir' v = throwFalse =<< (withCString v $ fcConfigAppFontAddDir nullPtr) foreign import ccall "FcConfigAppFontAddDir" fcConfigAppFontAddDir :: Config_ -> CString -> IO Bool -configAppFontClear :: Config -> IO Bool -configAppFontClear = flip withForeignPtr fcConfigAppFontClear -configAppFontClear' :: IO Bool -configAppFontClear' = fcConfigAppFontClear nullPtr +configAppFontClear :: Config -> IO () +configAppFontClear config = throwFalse =<< withForeignPtr config fcConfigAppFontClear +configAppFontClear' :: IO () +configAppFontClear' = throwFalse =<< fcConfigAppFontClear nullPtr foreign import ccall "FcConfigAppFontClear" fcConfigAppFontClear :: Config_ -> IO Bool data MatchKind = MatchPattern | MatchFont | MatchScan deriving Enum -configSubstituteWithPat :: Config -> Pattern -> Pattern -> MatchKind -> Maybe Pattern +configSubstituteWithPat :: Config -> Pattern -> Pattern -> MatchKind -> Pattern configSubstituteWithPat config p p_pat kind = unsafePerformIO $ withForeignPtr config $ \config' -> withPattern p $ \p' -> withPattern p_pat $ \p_pat' -> do ok <- fcConfigSubstituteWithPat config' p' p_pat' $ fromEnum kind - if ok then Just <$> thawPattern p' else return Nothing -configSubstituteWithPat' :: Pattern -> Pattern -> MatchKind -> Maybe Pattern + throwFalse ok + thawPattern p' +configSubstituteWithPat' :: Pattern -> Pattern -> MatchKind -> Pattern configSubstituteWithPat' p p_pat kind = unsafePerformIO $ withPattern p $ \p' -> withPattern p_pat $ \p_pat' -> do ok <- fcConfigSubstituteWithPat nullPtr p' p_pat' $ fromEnum kind - if ok then Just <$> thawPattern p' else return Nothing + throwFalse ok + thawPattern p' foreign import ccall "FcConfigSubstituteWithPat" fcConfigSubstituteWithPat :: Config_ -> Pattern_ -> Pattern_ -> Int -> IO Bool -configSubstitute :: Config -> Pattern -> MatchKind -> Maybe Pattern +configSubstitute :: Config -> Pattern -> MatchKind -> Pattern configSubstitute config p kind = unsafePerformIO $ withForeignPtr config $ \config' -> withPattern p $ \p' -> do ok <- fcConfigSubstitute config' p' $ fromEnum kind - if ok then Just <$> thawPattern p' else return Nothing -configSubstitute' :: Pattern -> MatchKind -> Maybe Pattern + throwFalse ok + thawPattern p' +configSubstitute' :: Pattern -> MatchKind -> Pattern configSubstitute' p kind = unsafePerformIO $ withPattern p $ \p' -> do ok <- fcConfigSubstitute nullPtr p' $ fromEnum kind - if ok then Just <$> thawPattern p' else return Nothing + throwFalse ok + thawPattern p' foreign import ccall "FcConfigSubstitute" fcConfigSubstitute :: Config_ -> Pattern_ -> Int -> IO Bool @@ -155,13 +161,11 @@ fontMatch :: Config -> Pattern -> Maybe Pattern fontMatch config pattern = unsafePerformIO $ withForeignPtr config $ \config' -> withPattern pattern $ \pattern' -> alloca $ \res' -> do ret <- fcFontMatch config' pattern' res' - res <- peek res' - if res == 0 then Just <$> thawPattern ret else return Nothing + throwPtr res' $ thawPattern_ $ pure ret fontMatch' :: Pattern -> Maybe Pattern fontMatch' pattern = unsafePerformIO $ withPattern pattern $ \pattern' -> alloca $ \res' -> do ret <- fcFontMatch nullPtr pattern' res' - res <- peek res' - if res == 0 then Just <$> thawPattern ret else return Nothing + throwPtr res' $ thawPattern_ $ pure ret foreign import ccall "FcFontMatch" fcFontMatch :: Config_ -> Pattern_ -> Ptr Int -> IO Pattern_ @@ -169,14 +173,12 @@ fontSort :: Config -> Pattern -> Bool -> CharSet -> Maybe FontSet fontSort config pattern trim csp = unsafePerformIO $ withForeignPtr config $ \config' -> withPattern pattern $ \pattern' -> withCharSet csp $ \csp' -> alloca $ \res' -> do ret <- fcFontSort config' pattern' trim csp' res' - res <- peek res' - if res == 0 then Just <$> thawFontSet ret else return Nothing + throwPtr res' $ thawFontSet_ $ pure ret fontSort' :: Pattern -> Bool -> CharSet -> Maybe FontSet fontSort' pattern trim csp = unsafePerformIO $ withPattern pattern $ \pattern' -> withCharSet csp $ \csp' -> alloca $ \res' -> do ret <- fcFontSort nullPtr pattern' trim csp' res' - res <- peek res' - if res == 0 then Just <$> thawFontSet ret else return Nothing + throwPtr res' $ thawFontSet_ $ pure ret foreign import ccall "FcFontSort" fcFontSort :: Config_ -> Pattern_ -> Bool -> CharSet_ -> Ptr Int -> IO FontSet_ @@ -184,12 +186,12 @@ fontRenderPrepare :: Config -> Pattern -> Pattern -> Pattern fontRenderPrepare config pat font = unsafePerformIO $ withForeignPtr config $ \config' -> withPattern pat $ \pat' -> withPattern font $ \font' -> do ret <- fcFontRenderPrepare config' pat' font' - thawPattern ret + thawPattern_ $ pure $ throwNull ret fontRenderPrepare' :: Pattern -> Pattern -> Pattern fontRenderPrepare' pat font = unsafePerformIO $ withPattern pat $ \pat' -> withPattern font $ \font' -> do ret <- fcFontRenderPrepare nullPtr pat' font' - thawPattern ret + thawPattern_ $ pure ret foreign import ccall "FcFontRenderPrepare" fcFontRenderPrepare :: Config_ -> Pattern_ -> Pattern_ -> IO Pattern_ @@ -197,11 +199,11 @@ fontList :: Config -> Pattern -> ObjectSet -> FontSet fontList config p os = unsafePerformIO $ withForeignPtr config $ \config' -> withPattern p $ \p' -> withObjectSet os $ \os' -> do ret <- fcFontList config' p' os' - thawFontSet ret + thawFontSet_ $ pure ret fontList' :: Pattern -> ObjectSet -> FontSet fontList' p os = unsafePerformIO $ withPattern p $ \p' -> withObjectSet os $ \os' -> do ret <- fcFontList nullPtr p' os' - thawFontSet ret + thawFontSet_ $ pure ret foreign import ccall "FcFontList" fcFontList :: Config_ -> Pattern_ -> ObjectSet_ -> IO FontSet_ @@ -209,12 +211,13 @@ configGetFilename :: Config -> String -> String configGetFilename config name = unsafePerformIO $ withForeignPtr config $ \config' -> withCString name $ \name' -> do ret <- fcConfigGetFilename config' name' - peekCString ret + peekCString' ret configGetFilename' :: String -> String configGetFilename' name = unsafePerformIO $ withCString name $ \name' -> do ret <- fcConfigGetFilename nullPtr name' - peekCString ret + peekCString' ret foreign import ccall "FcConfigGetFilename" fcConfigGetFilename :: Config_ -> CString -> IO CString +peekCString' txt = bracket (pure $ throwNull txt) free peekCString configParseAndLoad :: Config -> String -> Bool -> IO Bool configParseAndLoad config name complain = withForeignPtr config $ \config' -> @@ -238,9 +241,9 @@ foreign import ccall "FcConfigParseAndLoadFromMemory" fcConfigParseAndLoadFromMe configGetSysRoot :: Config -> IO String configGetSysRoot = flip withForeignPtr $ \config' -> do ret <- fcConfigGetSysRoot config' - peekCString ret + peekCString $ throwNull ret configGetSysRoot' :: IO String -configGetSysRoot' = peekCString =<< fcConfigGetSysRoot nullPtr +configGetSysRoot' = (peekCString .throwNull) =<< fcConfigGetSysRoot nullPtr foreign import ccall "FcConfigGetSysRoot" fcConfigGetSysRoot :: Config_ -> IO CString configSetSysRoot :: Config -> String -> IO () -- 2.30.2