~alcinnz/fontconfig-pure

ref: fcf1e371e4a7d55b5ae07b90172502bc1d3e8064 fontconfig-pure/FreeType/FontConfig.hs -rw-r--r-- 3.0 KiB
fcf1e371 — Adrian Cochrane Remove file utility & throw memory exceptions for String utilities. 2 years ago 
                                                                                
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
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!