8 files changed, 74 insertions(+), 19 deletions(-)

M FreeType/FontConfig.hs
M Graphics/Text/Font/Choose/CharSet.hs
M Graphics/Text/Font/Choose/Config.hs
M Graphics/Text/Font/Choose/FontSet.hs
M Graphics/Text/Font/Choose/Result.hs
A app/Main.hs
M cbits/pattern.c
M fontconfig-pure.cabal

@@ 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

@@ 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 ::

@@ 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)

@@ 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

@@ 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
 

@@ 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

@@ 2,7 2,7 @@
 #include <stddef.h>
 
 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,

@@ 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
+