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
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
{-# LANGUAGE DeriveGeneric #-}
module Graphics.Text.Font.Choose.Value where
import Linear.Matrix (M22)
import Linear.V2 (V2(..))
import Graphics.Text.Font.Choose.CharSet (CharSet, withCharSet, thawCharSet)
import FreeType.Core.Base (FT_Face(..))
import Graphics.Text.Font.Choose.LangSet (LangSet, withLangSet, thawLangSet)
import Graphics.Text.Font.Choose.Range (Range, withRange, thawRange)
import Foreign.Ptr (Ptr, castPtr)
import Foreign.Storable (Storable(..))
import Foreign.Marshal.Array (advancePtr)
import Foreign.Marshal.Alloc (allocaBytes)
import Foreign.C.String (withCString, peekCString)
import GHC.Generics (Generic)
import Data.Hashable (Hashable)
data Value = ValueVoid
| ValueInt Int
| ValueDouble Double
| ValueString String
| ValueBool Bool
| ValueMatrix (M22 Double)
| ValueCharSet CharSet
| ValueFTFace FT_Face
| ValueLangSet LangSet
| ValueRange Range deriving (Eq, Show, Ord, Generic)
instance Hashable Value
------
--- Low-level
------
type Value_ = Ptr Int
foreign import ccall "sizeof_Value" value'Size :: Int
pokeUnion ptr x = castPtr (ptr `advancePtr` 1) `poke` x
withValue :: Value -> (Value_ -> IO a) -> IO a
withValue ValueVoid cb = allocaBytes value'Size $ \val' -> do
poke val' 0
cb val'
withValue (ValueInt x) cb = allocaBytes value'Size $ \val' -> do
poke val' 1
pokeElemOff val' 1 x
cb val'
withValue (ValueDouble x) cb = allocaBytes value'Size $ \val' -> do
poke val' 2
pokeUnion val' x
cb val'
withValue (ValueString str) cb =
withCString str $ \str' -> allocaBytes value'Size $ \val' -> do
poke val' 3
pokeUnion val' str'
cb val'
withValue (ValueBool b) cb = allocaBytes value'Size $ \val' -> do
poke val' 4
pokeUnion val' b
cb val'
withValue (ValueMatrix mat) cb =
withMatrix mat $ \mat' -> allocaBytes value'Size $ \val' -> do
poke val' 5
pokeUnion val' mat'
cb val'
withValue (ValueCharSet charsets) cb =
withCharSet charsets $ \charsets' -> allocaBytes value'Size $ \val' -> do
poke val' 6
pokeUnion val' charsets'
cb val'
withValue (ValueFTFace x) cb = allocaBytes value'Size $ \val' -> do
poke val' 7
pokeUnion val' x
cb val'
withValue (ValueLangSet langset) cb =
withLangSet langset $ \langset' -> allocaBytes value'Size $ \val' -> do
poke val' 8
pokeUnion val' langset'
cb val'
withValue (ValueRange range) cb =
withRange range $ \range' -> allocaBytes value'Size $ \val' -> do
poke val' 9
pokeUnion val' range'
cb val'
foreign import ccall "size_matrix" mat22Size :: Int
withMatrix (V2 (V2 xx yx) (V2 xy yy)) cb = allocaBytes mat22Size $ \mat' -> do
pokeElemOff mat' 0 xx
pokeElemOff mat' 1 xy
pokeElemOff mat' 2 yx
pokeElemOff mat' 3 yy
cb mat'
thawValue :: Value_ -> IO (Maybe Value)
thawValue ptr = do
kind <- peek ptr
let val' = castPtr (ptr `advancePtr` 1)
case kind of
0 -> return $ Just ValueVoid
1 -> Just <$> ValueInt <$> peek val'
2 -> Just <$> ValueDouble <$> peek val'
3 -> Just <$> ValueString <$> peekCString val'
4 -> do
mat' <- peek val'
xx <- peekElemOff mat' 0
xy <- peekElemOff mat' 1
yx <- peekElemOff mat' 2
yy <- peekElemOff mat' 3
return $ Just $ ValueMatrix $ V2 (V2 xx yx) (V2 xy yy)
5 -> Just <$> ValueCharSet <$> thawCharSet val'
6 -> return $ Just $ ValueFTFace $ val'
7 -> Just <$> ValueLangSet <$> thawLangSet val'
8 -> Just <$> ValueRange <$> thawRange val'
_ -> return Nothing