1 files changed, 68 insertions(+), 0 deletions(-)

A FreeType/FontConfig.hs

@@ 0,0 1,68 @@
+-- NOTE: Not tested
+module FreeType.FontConfig (ftCharIndex, ftCharSet, ftCharSetAndSpacing,
+    ftQuery, ftQueryAll, ftQueryFace) where
+
+import Graphics.Text.Font.Choose.CharSet (CharSet, CharSet_, thawCharSet, thawCharSet_)
+import Graphics.Text.Font.Choose.Pattern (Pattern, Pattern_, thawPattern, thawPattern_)
+import Graphics.Text.Font.Choose.FontSet (FontSet, FontSet_, withFontSet, thawFontSet)
+import FreeType.Core.Base (FT_Face(..))
+import Data.Word (Word32, Word)
+
+import Foreign.Ptr (nullPtr, Ptr)
+import Foreign.Storable (peek)
+import Foreign.Marshal.Alloc (alloca)
+import Foreign.C.String (CString, withCString)
+import System.IO.Unsafe (unsafePerformIO)
+
+import Control.Exception (throw)
+import Graphics.Text.Font.Choose.Result (Error(ErrTypeMismatch))
+
+c2w :: Char -> Word32
+c2w = fromIntegral . fromEnum
+
+ftCharIndex :: FT_Face -> Char -> Word
+ftCharIndex face = fcFreeTypeCharIndex face . c2w
+foreign import ccall "FcFreeTypeCharIndex" fcFreeTypeCharIndex :: FT_Face -> Word32 -> Word
+
+ftCharSet :: FT_Face -> CharSet
+ftCharSet face = unsafePerformIO $ thawCharSet_ $ fcFreeTypeCharSet face nullPtr
+foreign import ccall "FcFreeTypeCharSet" fcFreeTypeCharSet
+    :: FT_Face -> Ptr () -> IO CharSet_ -- 2nd arg's deprecated!
+
+data Spacing = Proportional | Dual | Mono
+ftCharSetAndSpacing :: FT_Face -> (CharSet, Spacing)
+ftCharSetAndSpacing face = unsafePerformIO $ alloca $ \spacing' -> do
+    chars <- thawCharSet_ $ fcFreeTypeCharSetAndSpacing face nullPtr spacing'
+    spacing_ <- peek spacing'
+    let spacing = case spacing_ of{
+        0 -> Proportional;
+        90 -> Dual;
+        100 -> Mono;
+        _ -> throw ErrTypeMismatch}
+    return (chars, spacing)
+foreign import ccall "FcFreeTypeCharSetAndSpacing" fcFreeTypeCharSetAndSpacing ::
+    FT_Face -> Ptr () -> Ptr Int -> IO CharSet_ -- 2nd arg's deprecated!
+
+ftQuery :: FilePath -> Int -> IO (Pattern, Int)
+ftQuery filename id = withCString filename $ \filename' -> alloca $ \count' -> do
+    pattern <- thawPattern_ $ fcFreeTypeQuery filename' id nullPtr count'
+    count <- peek count'
+    return (pattern, count)
+foreign import ccall "FcFreeTypeQuery" fcFreeTypeQuery ::
+    CString -> Int -> Ptr () -> Ptr Int -> IO Pattern_ -- 3rd arg's deprecated!
+
+ftQueryAll :: FilePath -> Int -> IO (FontSet, Int)
+ftQueryAll filename id = withCString filename $ \filename' -> alloca $ \count' ->
+    withFontSet [] $ \fonts' -> do
+        fcFreeTypeQueryAll filename' id nullPtr count' fonts'
+        fonts <- thawFontSet fonts'
+        count <- peek count'
+        return (fonts, count)
+foreign import ccall "FcFreeTypeQueryAll" fcFreeTypeQueryAll ::
+    CString -> Int -> Ptr () -> Ptr Int -> FontSet_ -> IO Word -- 2nd arg's deprecated!
+
+ftQueryFace :: FT_Face -> FilePath -> Int -> IO Pattern
+ftQueryFace face filename id = withCString filename $ \filename' ->
+    thawPattern_ $ fcFreeTypeQueryFace face filename' id nullPtr
+foreign import ccall "FcFreeTypeQueryFace" fcFreeTypeQueryFace ::
+    FT_Face -> CString -> Int -> Ptr () -> IO Pattern_ -- Final arg's deprecated!