module Graphics.HGL.Draw.Font
( Font
, createFont
, deleteFont
, selectFont
, 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)
#if X_DISPLAY_MISSING
newtype Font = MkFont Win32.HFONT
#endif
createFont
:: Size
-> Angle
-> Bool
-> Bool
-> String
-> IO Font
deleteFont :: Font -> IO ()
selectFont :: Font -> Draw Font
mkFont :: Size
-> Angle
-> Bool
-> Bool
-> String
-> (Font -> Draw a)
-> Draw a
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
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 = "*"
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)
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
weight
italic False False
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 */