From c10cdcf25bbe2176a84a38b6f967d584223112b3 Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Wed, 23 Nov 2022 16:32:47 +1300 Subject: [PATCH] Fixes to decoding FcFontSets, still experiencing segfaults... --- Graphics/Text/Font/Choose.hs | 9 +++++---- Graphics/Text/Font/Choose/Config.hs | 26 ++++++++++++++++---------- Graphics/Text/Font/Choose/FontSet.hs | 17 +++++++++++------ Graphics/Text/Font/Choose/Pattern.hs | 9 +++++---- Main.hs | 17 ++++++++++++++--- cbits/pattern.c | 8 ++++++++ 6 files changed, 59 insertions(+), 27 deletions(-) diff --git a/Graphics/Text/Font/Choose.hs b/Graphics/Text/Font/Choose.hs index 7265dac..049d01b 100644 --- a/Graphics/Text/Font/Choose.hs +++ b/Graphics/Text/Font/Choose.hs @@ -10,7 +10,7 @@ module Graphics.Text.Font.Choose(CharSet, FontSet, ObjectSet, Pattern(..), Bindi configAppFontAddFile, configAppFontAddFile', configAppFontAddDir, configAppFontAddDir', MatchKind(..), configSubstituteWithPat, configSubstituteWithPat', fontList, fontList', configSubstitute, configSubstitute', fontMatch, fontMatch', fontSort, fontSort', - fontRenderPrepare, fontRenderPrepare', configGetFilename, configGetFilename', + fontRenderPrepare, fontRenderPrepare', -- configGetFilename, configGetFilename', configParseAndLoad, configParseAndLoad', configGetSysRoot, configGetSysRoot', configParseAndLoadFromMemory, configParseAndLoadFromMemory', configSetSysRoot, configSetSysRoot', configGetFileInfo, configGetFileInfo', @@ -21,7 +21,8 @@ module Graphics.Text.Font.Choose(CharSet, FontSet, ObjectSet, Pattern(..), Bindi LangSet, defaultLangs, langs, langSetCompare, langNormalize, langCharSet, - equalSubset, normalizePattern, filter, substitute, nameParse, nameUnparse, format) where + equalSubset, normalizePattern, filter, defaultSubstitute, nameParse, nameUnparse, format + ) where import Prelude hiding (init, filter) @@ -35,7 +36,7 @@ import Graphics.Text.Font.Choose.Config (Config, configCreate, configAppFontAddFile, configAppFontAddFile', configAppFontAddDir, configAppFontAddDir', MatchKind(..), configSubstituteWithPat, configSubstituteWithPat', fontList, fontList', configSubstitute, configSubstitute', fontMatch, fontMatch', fontSort, fontSort', - fontRenderPrepare, fontRenderPrepare', configGetFilename, configGetFilename', + fontRenderPrepare, fontRenderPrepare', -- configGetFilename, configGetFilename', configParseAndLoad, configParseAndLoad', configGetSysRoot, configGetSysRoot', configParseAndLoadFromMemory, configParseAndLoadFromMemory', configSetSysRoot, configSetSysRoot', configGetFileInfo, configGetFileInfo') @@ -48,7 +49,7 @@ import Graphics.Text.Font.Choose.LangSet (LangSet, defaultLangs, langs, langSetCompare, langNormalize, langCharSet) import Graphics.Text.Font.Choose.ObjectSet (ObjectSet) import Graphics.Text.Font.Choose.Pattern (Pattern(..), Binding(..), equalSubset, - normalizePattern, filter, substitute, nameParse, nameUnparse, format) + normalizePattern, filter, defaultSubstitute, nameParse, nameUnparse, format) import Graphics.Text.Font.Choose.Range (Range(..), iRange) import Graphics.Text.Font.Choose.Strings (StrSet, StrList) import Graphics.Text.Font.Choose.Value (Value(..)) diff --git a/Graphics/Text/Font/Choose/Config.hs b/Graphics/Text/Font/Choose/Config.hs index ee99893..f21656c 100644 --- a/Graphics/Text/Font/Choose/Config.hs +++ b/Graphics/Text/Font/Choose/Config.hs @@ -170,16 +170,22 @@ fontMatch' pattern = unsafePerformIO $ withPattern pattern $ \pattern' -> alloca foreign import ccall "FcFontMatch" fcFontMatch :: Config_ -> Pattern_ -> Ptr Int -> IO Pattern_ -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 +fontSort :: Config -> Pattern -> Bool -> Maybe (FontSet, CharSet) +fontSort config pattern trim = unsafePerformIO $ withForeignPtr config $ \config' -> + withPattern pattern $ \pattern' -> withNewCharSet $ \csp' -> alloca $ \res' -> do ret <- fcFontSort config' pattern' trim csp' res' - 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 + throwPtr res' $ do + x <- thawFontSet_ $ pure $ throwNull ret + y <- thawCharSet $ throwNull csp' + return (x, y) +fontSort' :: Pattern -> Bool -> Maybe (FontSet, CharSet) +fontSort' pattern trim = unsafePerformIO $ withPattern pattern $ \pattern' -> + withNewCharSet $ \csp' -> alloca $ \res' -> do ret <- fcFontSort nullPtr pattern' trim csp' res' - throwPtr res' $ thawFontSet_ $ pure ret + throwPtr res' $ do + x <- thawFontSet_ $ pure $ throwNull ret + y <- thawCharSet $ throwNull csp' + return (x, y) foreign import ccall "FcFontSort" fcFontSort :: Config_ -> Pattern_ -> Bool -> CharSet_ -> Ptr Int -> IO FontSet_ @@ -208,7 +214,7 @@ fontList' p os = unsafePerformIO $ withPattern p $ \p' -> withObjectSet os $ \os foreign import ccall "FcFontList" fcFontList :: Config_ -> Pattern_ -> ObjectSet_ -> IO FontSet_ -configGetFilename :: Config -> String -> String +{-configGetFilename :: Config -> String -> String configGetFilename config name = unsafePerformIO $ withForeignPtr config $ \config' -> withCString name $ \name' -> do ret <- fcConfigGetFilename config' name' @@ -218,7 +224,7 @@ configGetFilename' name = unsafePerformIO $ withCString name $ \name' -> do ret <- fcConfigGetFilename nullPtr name' peekCString' ret foreign import ccall "FcConfigGetFilename" fcConfigGetFilename :: Config_ -> CString -> IO CString -peekCString' txt = bracket (pure $ throwNull txt) free peekCString +peekCString' txt = bracket (pure $ throwNull txt) free peekCString-} configParseAndLoad :: Config -> String -> Bool -> IO Bool configParseAndLoad config name complain = withForeignPtr config $ \config' -> diff --git a/Graphics/Text/Font/Choose/FontSet.hs b/Graphics/Text/Font/Choose/FontSet.hs index aa6a7ad..fe7d717 100644 --- a/Graphics/Text/Font/Choose/FontSet.hs +++ b/Graphics/Text/Font/Choose/FontSet.hs @@ -5,9 +5,9 @@ import Graphics.Text.Font.Choose.Pattern import Graphics.Text.Font.Choose.Result (throwFalse, throwNull) import Foreign.Ptr (Ptr, castPtr, nullPtr) -import Foreign.Storable (pokeElemOff, sizeOf, peek) +import Foreign.Storable (pokeElemOff, sizeOf) import Foreign.Marshal.Alloc (allocaBytes) -import Foreign.Marshal.Array (advancePtr) +import Foreign.Marshal.Array (peekArray) import Control.Monad (forM) import Control.Exception (bracket) @@ -16,7 +16,7 @@ type FontSet = [Pattern] ------ --- Low-level ------ -type FontSet' = Int +data FontSet' type FontSet_ = Ptr FontSet' withNewFontSet :: (FontSet_ -> IO a) -> IO a @@ -44,10 +44,15 @@ withFontSets' (fonts:fontss) i fontss' cb = withFontSet fonts $ \fonts' -> do thawFontSet :: FontSet_ -> IO FontSet thawFontSet fonts' = do - n <- peek fonts' - array <- peek $ castPtr $ advancePtr fonts' 2 + n <- get_fontSet_nfont fonts' + array <- get_fontSet_fonts fonts' if n == 0 || array == nullPtr then return [] - else forM [0..pred n] $ \i -> thawPattern =<< peek (advancePtr array i) + else do + list <- peekArray n array + forM list (thawPattern . throwNull) +foreign import ccall "get_fontSet_nfont" get_fontSet_nfont :: FontSet_ -> IO Int +foreign import ccall "get_fontSet_fonts" get_fontSet_fonts :: FontSet_ -> IO (Ptr Pattern_) + thawFontSet_ :: IO FontSet_ -> IO FontSet thawFontSet_ cb = bracket (throwNull <$> cb) fcFontSetDestroy thawFontSet diff --git a/Graphics/Text/Font/Choose/Pattern.hs b/Graphics/Text/Font/Choose/Pattern.hs index 2a7c031..dd36b09 100644 --- a/Graphics/Text/Font/Choose/Pattern.hs +++ b/Graphics/Text/Font/Choose/Pattern.hs @@ -1,6 +1,6 @@ {-# LANGUAGE DeriveGeneric #-} module Graphics.Text.Font.Choose.Pattern (Pattern(..), Binding(..), equalSubset, - normalizePattern, filter, substitute, nameParse, nameUnparse, format, + normalizePattern, filter, defaultSubstitute, nameParse, nameUnparse, format, Pattern_, withPattern, thawPattern, thawPattern_, patternAsPointer) where import Prelude hiding (filter) @@ -48,8 +48,8 @@ filter pat objs = foreign import ccall "FcPatternFilter" fcPatternFilter :: Pattern_ -> ObjectSet_ -> IO Pattern_ -substitute :: Pattern -> Pattern -substitute pat = unsafePerformIO $ withPattern pat $ \pat' -> do +defaultSubstitute :: Pattern -> Pattern +defaultSubstitute pat = unsafePerformIO $ withPattern pat $ \pat' -> do ret <- fcDefaultSubstitute pat' thawPattern pat' foreign import ccall "FcDefaultSubstitute" fcDefaultSubstitute :: Pattern_ -> IO () @@ -131,7 +131,8 @@ thawPattern' pat' iter' = do binding <- peek binding' val' <- thawValue val' return $ case val' of - Just val -> Just (toEnum binding, val) + Just val | binding >= 0 && binding <= 2 -> Just (toEnum binding, val) + Just val -> Just (Same, val) Nothing -> Nothing return (obj, catMaybes $ map join values) foreign import ccall "FcPatternIterGetObject" fcPatternIterGetObject :: diff --git a/Main.hs b/Main.hs index 868e868..42d2c37 100644 --- a/Main.hs +++ b/Main.hs @@ -4,12 +4,23 @@ module Main where import "fontconfig-pure" Graphics.Text.Font.Choose as Font import System.Environment (getArgs) +import Control.Monad (forM) main :: IO () main = do args <- getArgs - let (name, objects) = case args of { - [] -> ("serif", []); - name:objects -> (name, objects)} + let (all, name, objects) = case args of { + [] -> (False, "serif", []); + "!":name:objects -> (True, name, objects); + name:objects -> (False, name, objects)} let query = nameParse name print query + let query' = defaultSubstitute $ configSubstitute' query MatchPattern + print query' + + case fontSort' query' all of + Just (res, charset) -> do + print charset + forM res $ \res' -> print $ fontRenderPrepare' query' res' + return () + Nothing -> putStrLn "No results!" diff --git a/cbits/pattern.c b/cbits/pattern.c index 393c6a6..c947988 100644 --- a/cbits/pattern.c +++ b/cbits/pattern.c @@ -26,3 +26,11 @@ int size_PatternIter() { int size_ConfigFileInfoIter() { return sizeof(FcConfigFileInfoIter); } + +int get_fontSet_nfont(FcFontSet *fonts) { + return fonts->nfont; +} + +FcPattern **get_fontSet_fonts(FcFontSet *fonts) { + return fonts->fonts; +} -- 2.30.2