~alcinnz/fontconfig-pure

ref: dbefdc068d0644a778f12cc661e87a4086429505 fontconfig-pure/lib/Graphics/Text/Font/Choose/Internal/FFI.hs -rw-r--r-- 2.8 KiB
dbefdc06 — Adrian Cochrane Document modules. 6 months ago
                                                                                
dbefdc06 Adrian Cochrane
1abac8a1 Adrian Cochrane
bea597e7 Adrian Cochrane
063d2469 Adrian Cochrane
9aee49dd Adrian Cochrane
bea597e7 Adrian Cochrane
9aee49dd Adrian Cochrane
bea597e7 Adrian Cochrane
063d2469 Adrian Cochrane
bea597e7 Adrian Cochrane
063d2469 Adrian Cochrane
bea597e7 Adrian Cochrane
063d2469 Adrian Cochrane
bea597e7 Adrian Cochrane
063d2469 Adrian Cochrane
bea597e7 Adrian Cochrane
063d2469 Adrian Cochrane
9aee49dd Adrian Cochrane
bea597e7 Adrian Cochrane
9aee49dd Adrian Cochrane
bea597e7 Adrian Cochrane
063d2469 Adrian Cochrane
bea597e7 Adrian Cochrane
9aee49dd Adrian Cochrane
063d2469 Adrian Cochrane
9aee49dd Adrian Cochrane
bea597e7 Adrian Cochrane
9aee49dd Adrian Cochrane
063d2469 Adrian Cochrane
9aee49dd Adrian Cochrane
bea597e7 Adrian Cochrane
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
69
70
71
72
73
-- | Utilities for writing language bindings transferring complex parameters.
-- Encoding & decoding parameters via MessagePack.
module Graphics.Text.Font.Choose.Internal.FFI(
        unpackWithErr, withMessageIO, withMessage, fromMessage, fromMessage0,
        fromMessageIO0, withCString', peekCString', withForeignPtr'
    ) where

import Data.MessagePack (MessagePack(fromObject), pack, unpack, Object(ObjectStr))
import Foreign.C.String (CString, withCString, peekCString)
import Foreign.Ptr (Ptr)
import Foreign.ForeignPtr (ForeignPtr, withForeignPtr)
import Foreign.Storable (Storable(..))
import Foreign.Marshal.Alloc (alloca, free)
import Data.Tuple (swap)
import Graphics.Text.Font.Choose.Result (throwNull, FcException)
import Data.Maybe (fromJust)
import Text.Read (readMaybe)
import Control.Exception (throw)

import Data.ByteString.Unsafe (unsafeUseAsCStringLen, unsafePackMallocCStringLen)
import Data.ByteString.Lazy (toStrict, fromStrict, ByteString)
import qualified Data.Text as Txt
import System.IO.Unsafe (unsafePerformIO)

unpackWithErr :: MessagePack a => ByteString -> Maybe a
unpackWithErr bs = case unpack bs of
    Just (ObjectStr err) |
        Just x <- (readMaybe $ Txt.unpack err :: Maybe FcException) -> throw x
    Just x -> fromObject x
    Nothing -> Nothing

withMessageIO :: MessagePack a => (CString -> Int -> IO b) -> a -> IO b
withMessageIO cb a = unsafeUseAsCStringLen (toStrict $ pack a) (uncurry cb)

withMessage :: MessagePack a => (CString -> Int -> b) -> a -> b
withMessage inner arg = unsafePerformIO $ withMessageIO (\x -> return . inner x) arg

fromMessage :: MessagePack a => (Ptr Int -> CString) -> Maybe a
fromMessage inner = unpackWithErr $ fromStrict $ unsafePerformIO $ do
    unsafePackMallocCStringLen . swap =<< withPtr (throwNull . inner)

fromMessage0 :: MessagePack a => (Ptr Int -> CString) -> a
fromMessage0 = fromJust . fromMessage

fromMessageIO :: MessagePack a => (Ptr Int -> IO CString) -> IO (Maybe a)
fromMessageIO inner = do
    (a, b) <- withPtr $ \ptr -> do
        throwNull =<< inner ptr
    bs <- unsafePackMallocCStringLen (b, a)
    return $ unpackWithErr $ fromStrict bs

fromMessageIO0 :: MessagePack a => (Ptr Int -> IO CString) -> IO a
fromMessageIO0 inner = fromJust <$> fromMessageIO inner

withCString' :: (CString -> a) -> String -> a
withCString' inner = unsafePerformIO . flip withCString (return . inner)

peekCString' :: CString -> String
peekCString' ptr = unsafePerformIO $ do
    ret <- peekCString ptr
    free ptr
    return ret

withForeignPtr' :: (Ptr a -> b) -> ForeignPtr a -> b
withForeignPtr' inner arg = unsafePerformIO $ withForeignPtr arg $ return . inner

-- I don't want to pull in all of inline-c for this util!
withPtr :: (Storable a) => (Ptr a -> IO b) -> IO (a, b)
withPtr f = do
  alloca $ \ptr -> do
    x <- f ptr
    y <- peek ptr
    return (y, x)