From 8abf298021bdbd08bbac04628ff88f5b0ad69ad0 Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Mon, 30 Jan 2023 15:15:05 +1300 Subject: [PATCH] Fix various segfaults & exercise bridging from FcPatterns to Ft_Faces. --- FreeType/FontConfig.hs | 8 ++++-- Graphics/Text/Font/Choose/CharSet.hs | 25 +++++++++-------- Graphics/Text/Font/Choose/Config.hs | 1 + Graphics/Text/Font/Choose/FontSet.hs | 2 +- Graphics/Text/Font/Choose/Result.hs | 6 ++-- app/Main.hs | 41 ++++++++++++++++++++++++++++ cbits/pattern.c | 2 +- fontconfig-pure.cabal | 8 ++++++ 8 files changed, 74 insertions(+), 19 deletions(-) create mode 100644 app/Main.hs diff --git a/FreeType/FontConfig.hs b/FreeType/FontConfig.hs index 0809702..1c301c9 100644 --- a/FreeType/FontConfig.hs +++ b/FreeType/FontConfig.hs @@ -1,6 +1,8 @@ -- NOTE: Not tested module FreeType.FontConfig (ftCharIndex, ftCharSet, ftCharSetAndSpacing, - ftQuery, ftQueryAll, ftQueryFace) where + ftQuery, ftQueryAll, ftQueryFace, + FTFC_Instance(..), FTFC_Metrics(..), FTFC_Subpixel(..), instantiatePattern, + FTFC_Glyph(..), glyphForIndex) where import Graphics.Text.Font.Choose.CharSet (CharSet, CharSet_, thawCharSet, thawCharSet_) import Graphics.Text.Font.Choose.Pattern (Pattern, Pattern_, thawPattern, thawPattern_) @@ -149,14 +151,14 @@ data FTFC_Subpixel = SubpixelNone -- ^ From FontConfig. instantiatePattern :: FT_Library -> Pattern -> (Double, Double) -> IO FTFC_Instance instantiatePattern ftlib pattern (req_pt_size, req_px_size) = do let dpi = fromMaybe 75 $ getValue' "dpi" pattern :: Double - let size = fromMaybe req_pt_size $ getValue' "size" pattern ft_face <- case getValue "ftface" pattern of ValueFTFace x -> return x _ -> ft_New_Face ftlib (getValue0 "file" pattern) -- is a mutex needed? (toEnum $ fromMaybe 0 $ getValue' "index" pattern) - ft_Set_Pixel_Sizes ft_face 0 $ toEnum $ getValue0 "pixelsize" pattern + ft_Set_Pixel_Sizes ft_face 0 $ toEnum $ fromEnum $ + fromMaybe req_px_size $ getValue' "pixelsize" pattern let scalable = fromMaybe True $ getValue' "scalable" pattern let outline = fromMaybe True $ getValue' "outline" pattern (pixel_fixup, fixup_estimated) <- case getValue "pixelsizefixupfactor" pattern of diff --git a/Graphics/Text/Font/Choose/CharSet.hs b/Graphics/Text/Font/Choose/CharSet.hs index ddc84f3..91d4326 100644 --- a/Graphics/Text/Font/Choose/CharSet.hs +++ b/Graphics/Text/Font/Choose/CharSet.hs @@ -59,18 +59,19 @@ withCharSet chars cb = withNewCharSet $ \chars' -> do foreign import ccall "FcCharSetAddChar" fcCharSetAddChar :: CharSet_ -> Word32 -> IO Bool thawCharSet :: CharSet_ -> IO CharSet -thawCharSet chars' = allocaBytes fcCHARSET_MAP_SIZE $ \iter' -> alloca $ \next' -> do - first <- fcCharSetFirstPage chars' iter' next' - let go = do { - ch <- fcCharSetNextPage chars' iter' next'; - if ch == maxBound then return [] - else do - chs <- go - return (ch:chs) - } - if first == maxBound then return Set.empty else do - rest <- go - return $ Set.fromList $ map (unsafeChr . fromIntegral) (first:rest) +thawCharSet chars' + | chars' == nullPtr = return Set.empty + | otherwise = allocaBytes fcCHARSET_MAP_SIZE $ \iter' -> alloca $ \next' -> do + first <- fcCharSetFirstPage chars' iter' next' + let go = do + ch <- fcCharSetNextPage chars' iter' next'; + if ch == maxBound then return [] + else do + chs <- go + return (ch:chs) + if first == maxBound then return Set.empty else do + rest <- go + return $ Set.fromList $ map (unsafeChr . fromIntegral) (first:rest) foreign import ccall "FcCharSetFirstPage" fcCharSetFirstPage :: CharSet_ -> Ptr Word32 -> Ptr Word32 -> IO Word32 foreign import ccall "FcCharSetNextPage" fcCharSetNextPage :: diff --git a/Graphics/Text/Font/Choose/Config.hs b/Graphics/Text/Font/Choose/Config.hs index d71ba9c..d5423fb 100644 --- a/Graphics/Text/Font/Choose/Config.hs +++ b/Graphics/Text/Font/Choose/Config.hs @@ -12,6 +12,7 @@ import Foreign.Marshal.Alloc (alloca, allocaBytes, free) import Foreign.Storable (Storable(..)) import Foreign.C.String (CString, peekCString, withCString) import System.IO.Unsafe (unsafePerformIO) +import Data.Set (empty) -- For testing segfault source. import Control.Exception (bracket) import Graphics.Text.Font.Choose.Result (throwNull, throwFalse, throwPtr) diff --git a/Graphics/Text/Font/Choose/FontSet.hs b/Graphics/Text/Font/Choose/FontSet.hs index ee9fd73..da86741 100644 --- a/Graphics/Text/Font/Choose/FontSet.hs +++ b/Graphics/Text/Font/Choose/FontSet.hs @@ -63,7 +63,7 @@ thawFontSet fonts' = do if n == 0 then return [] else do print "c" - ret <- forM [0..pred n] (thawPattern_ . get_fontSet_font fonts') + ret <- forM [0..pred n] (\i -> thawPattern =<< get_fontSet_font fonts' i) print "d" return ret foreign import ccall "get_fontSet_nfont" get_fontSet_nfont :: FontSet_ -> IO Int diff --git a/Graphics/Text/Font/Choose/Result.hs b/Graphics/Text/Font/Choose/Result.hs index 5ad13f0..c66e78a 100644 --- a/Graphics/Text/Font/Choose/Result.hs +++ b/Graphics/Text/Font/Choose/Result.hs @@ -5,7 +5,7 @@ import Foreign.Storable (peek) import Foreign.Ptr (Ptr, nullPtr) import Control.Exception (throwIO, throw, Exception) -data Result = Match | NoMatch | TypeMismatch | ResultNoId | OutOfMemory +data Result = Match | NoMatch | TypeMismatch | ResultNoId | OutOfMemory | Other deriving (Eq, Show, Read, Enum) resultFromPointer :: Ptr Int -> IO Result @@ -22,7 +22,9 @@ throwResult ResultNoId _ = throwIO ErrResultNoId throwResult OutOfMemory _ = throwIO ErrOutOfMemory throwInt :: Int -> IO a -> IO (Maybe a) -throwInt = throwResult . toEnum +throwInt x + | x >= 0 && x <= 4 = throwResult $ toEnum x + | otherwise = throwResult $ Other throwPtr :: Ptr Int -> IO a -> IO (Maybe a) throwPtr a b = resultFromPointer a >>= flip throwResult b diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 index 0000000..7102898 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main where + +import Graphics.UI.GLUT +import Graphics.GL.Core32 + +import FreeType.Core.Base +import FreeType.FontConfig + +import Graphics.Text.Font.Choose as Font + +import System.Environment (getArgs) +import System.Exit (exitFailure) +import Data.Function (fix) +import Control.Monad (unless) +import Data.Maybe (fromMaybe) + +main :: IO () +main = do + (progName, args) <- getArgsAndInitialize + + w <- createWindow progName + + args <- getArgs + let query = nameParse $ case args of + [] -> "serif" + (q:_) -> q + let query' = defaultSubstitute $ configSubstitute' query MatchPattern + font <- case fontSort' query' False of + Just (f:_, _) -> return f + _ -> do + putStrLn ("Failed to locate font " ++ show query) + exitFailure + + ft_With_FreeType $ \ft -> do + inst <- instantiatePattern ft font (fromMaybe 12 $ getValue' "size" font, 20) + + displayCallback $= do + clear [ ColorBuffer ] + flush + mainLoop diff --git a/cbits/pattern.c b/cbits/pattern.c index 0eb7512..6754bda 100644 --- a/cbits/pattern.c +++ b/cbits/pattern.c @@ -2,7 +2,7 @@ #include int my_FcCHARSET_MAP_SIZE() { - return FC_CHARSET_MAP_SIZE; + return FC_CHARSET_MAP_SIZE*sizeof(FcChar32); } FcBool my_FcPatternAdd(FcPattern *p, const char *object, diff --git a/fontconfig-pure.cabal b/fontconfig-pure.cabal index ceeb2f1..5fc486f 100644 --- a/fontconfig-pure.cabal +++ b/fontconfig-pure.cabal @@ -107,3 +107,11 @@ test-suite test-fontconfig type: exitcode-stdio-1.0 main-is: Test.hs build-depends: base >= 4.12 && <4.13, fontconfig-pure, hspec, QuickCheck + +executable view-font + main-is: Main.hs + build-depends: base >=4.12 && <4.13, typograffiti>=0.2, text, + GLUT >= 2.7, gl, mtl, fontconfig-pure, freetype2 + hs-source-dirs: app + default-language: Haskell2010 + -- 2.30.2