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
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
|
-----------------------------------------------------------------------------
-- |
-- Module : Graphics.HGL.Draw.Font
-- Copyright : (c) Alastair Reid, 1999-2003
-- License : BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer : libraries@haskell.org
-- Stability : provisional
-- Portability : non-portable (requires concurrency)
--
-- Text fonts.
--
-- Portability notes:
--
-- * X11 does not directly support font rotation so 'createFont' and
-- 'mkFont' always ignore the rotation angle argument in the X11
-- implementation of this library.
--
-- * Many of the font families typically available on Win32 are not
-- available on X11 (and /vice-versa/). In our experience, the font
-- families /courier/, /helvetica/ and /times/ are somewhat portable.
--
-----------------------------------------------------------------------------
#include "HsHGLConfig.h"
module Graphics.HGL.Draw.Font
( Font
, createFont
, deleteFont
, selectFont -- :: Font -> Draw Font
, mkFont
) where
#if !X_DISPLAY_MISSING
import qualified Graphics.HGL.Internals.Utilities as Utils
import Graphics.HGL.X11.Types (Font(Font), DC(..), DC_Bits(..))
import Graphics.HGL.X11.Display (getDisplay)
import qualified Graphics.X11.Xlib as X
import Control.Concurrent.MVar (takeMVar, putMVar)
#else
import Graphics.HGL.Win32.Types
import qualified Graphics.Win32 as Win32
#endif
import Graphics.HGL.Units (Size, Angle)
import Graphics.HGL.Draw.Monad (Draw, bracket, ioToDraw)
import Graphics.HGL.Internals.Draw (mkDraw)
----------------------------------------------------------------
-- Interface
----------------------------------------------------------------
#if X_DISPLAY_MISSING
newtype Font = MkFont Win32.HFONT
#endif
-- | Create a font.
-- The rotation angle is ignored if the font is not a \"TrueType\" font
-- (e.g., a @System@ font on Win32).
createFont
:: Size -- ^ size of character glyphs in pixels
-> Angle -- ^ rotation angle
-> Bool -- ^ bold font?
-> Bool -- ^ italic font?
-> String -- ^ font family
-> IO Font
-- | Delete a font created with 'createFont'.
deleteFont :: Font -> IO ()
-- | Set the font for subsequent text, and return the previous font.
selectFont :: Font -> Draw Font
-- | Generate a font for use in a drawing, and delete it afterwards.
-- The rotation angle is ignored if the font is not a \"TrueType\" font
-- (e.g., a @System@ font on Win32).
mkFont :: Size -- ^ size of character glyphs in pixels
-> Angle -- ^ rotation angle
-> Bool -- ^ bold font?
-> Bool -- ^ italic font?
-> String -- ^ font family
-> (Font -> Draw a)
-> Draw a
----------------------------------------------------------------
-- Implementation
----------------------------------------------------------------
mkFont size angle bold italic family =
bracket (ioToDraw $ createFont size angle bold italic family)
(ioToDraw . deleteFont)
#if !X_DISPLAY_MISSING
createFont (width, height) escapement bold italic family = do
display <- getDisplay
-- print fontName
r <- Utils.safeTry (X.loadQueryFont display fontName)
case r of
Left e -> ioError (userError $ "Unable to load font " ++ fontName)
Right f -> return (Font f)
where
fontName = concatMap ('-':) fontParts
fontParts = [ foundry
, family
, weight
, slant
, sWdth
, adstyl
, pxlsz
, ptSz
, resx
, resy
, spc
, avgWidth
, registry
, encoding
]
foundry = "*" -- eg "adobe"
-- family = "*" -- eg "courier"
weight = if bold then "bold" else "medium"
slant = if italic then "i" else "r"
sWdth = "normal"
adstyl = "*"
pxlsz = show height
ptSz = "*"
resx = "75"
resy = "75"
spc = "*"
avgWidth = show (width*10) -- not sure what unit they use
registry = "*"
encoding = "*"
deleteFont (Font f) = do
display <- getDisplay
X.freeFont display f
selectFont f@(Font x) = mkDraw $ \ dc -> do
bs <- takeMVar (ref_bits dc)
putMVar (ref_bits dc) bs{font=f}
X.setFont (disp dc) (textGC dc) (X.fontFromFontStruct x)
return (font bs)
#else /* X_DISPLAY_MISSING */
createFont (width, height) escapement bold italic family =
Win32.createFont (fromDimension height) (fromDimension width)
(round (escapement * 1800/pi))
0 -- orientation
weight
italic False False -- italic, underline, strikeout
Win32.aNSI_CHARSET
Win32.oUT_DEFAULT_PRECIS
Win32.cLIP_DEFAULT_PRECIS
Win32.dEFAULT_QUALITY
Win32.dEFAULT_PITCH
family
>>= return . MkFont
where
weight | bold = Win32.fW_BOLD
| otherwise = Win32.fW_NORMAL
deleteFont (MkFont f) = Win32.deleteFont f
selectFont (MkFont f) = mkDraw (\hdc -> do
f' <- Win32.selectFont hdc f
return (MkFont f'))
#endif /* X_DISPLAY_MISSING */
----------------------------------------------------------------
-- End
----------------------------------------------------------------
|
