summaryrefslogtreecommitdiffhomepage
path: root/XUtil.hsc
diff options
context:
space:
mode:
Diffstat (limited to 'XUtil.hsc')
-rw-r--r--XUtil.hsc234
1 files changed, 234 insertions, 0 deletions
diff --git a/XUtil.hsc b/XUtil.hsc
new file mode 100644
index 0000000..0271f89
--- /dev/null
+++ b/XUtil.hsc
@@ -0,0 +1,234 @@
+{-# OPTIONS -fglasgow-exts #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : XUtil
+-- Copyright : (C) 2007 Andrea Rossato
+-- License : BSD3
+--
+-- Maintainer : andrea.rossato@unibz.it
+-- Stability : unstable
+-- Portability : unportable
+--
+-----------------------------------------------------------------------------
+
+module XUtil
+ ( XFont
+ , initFont
+ , initCoreFont
+ , initUtf8Font
+ , releaseFont
+ , textExtents
+ , textWidth
+ , printString
+ , initColor
+ , mkUnmanagedWindow
+ , nextEvent'
+ , readFileSafe
+ , hGetLineSafe
+ , io
+ , fi
+ ) where
+
+import Control.Concurrent
+import Control.Monad
+import Control.Monad.Trans
+import Foreign
+import Graphics.X11.Xlib hiding (textExtents, textWidth)
+import qualified Graphics.X11.Xlib as Xlib (textExtents, textWidth)
+import Graphics.X11.Xlib.Extras
+import System.Posix.Types (Fd(..))
+import System.IO
+#if defined XFT || defined UTF8
+import Foreign.C
+import qualified System.IO.UTF8 as UTF8 (readFile,hGetLine)
+#endif
+#if defined XFT
+import Data.List
+import Graphics.X11.Xft
+import Graphics.X11.Xrender
+#endif
+
+readFileSafe :: FilePath -> IO String
+#if defined XFT || defined UTF8
+readFileSafe = UTF8.readFile
+#else
+readFileSafe = readFile
+#endif
+
+hGetLineSafe :: Handle -> IO String
+#if defined XFT || defined UTF8
+hGetLineSafe = UTF8.hGetLine
+#else
+hGetLineSafe = hGetLine
+#endif
+
+-- Hide the Core Font/Xft switching here
+data XFont =Core FontStruct
+ | Utf8 FontSet
+#ifdef XFT
+ | Xft XftFont
+#endif
+
+-- | When initFont gets a font name that starts with 'xft:' it switchs to the Xft backend
+-- Example: 'xft:Sans-10'
+initFont :: Display ->String -> IO XFont
+initFont d s =
+#ifdef XFT
+ if xftPrefix `isPrefixOf` s then
+ do setupLocale
+ xftdraw <- xftFontOpen d (defaultScreenOfDisplay d) (drop (length xftPrefix) s)
+ return (Xft xftdraw)
+ else
+#endif
+#ifdef UTF8
+ (setupLocale >> initUtf8Font d s >>= (return . Utf8))
+#else
+ (initCoreFont d s >>= (return . Core))
+#endif
+#ifdef XFT
+ where xftPrefix = "xft:"
+#endif
+
+releaseFont :: Display -> XFont -> IO ()
+#ifdef XFT
+releaseFont d (Xft xftfont) = xftFontClose d xftfont
+#endif
+releaseFont d (Utf8 fs) = releaseUtf8Font d fs
+releaseFont d (Core fs) = releaseCoreFont d fs
+
+-- | Given a fontname returns the font structure. If the font name is
+-- not valid the default font will be loaded and returned.
+initCoreFont :: Display -> String -> IO FontStruct
+initCoreFont dpy s = catch (getIt dpy) (fallBack dpy)
+ where getIt d = loadQueryFont d s
+ fallBack d = const $ loadQueryFont d "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*"
+
+releaseCoreFont :: Display -> FontStruct -> IO ()
+releaseCoreFont d = freeFont d
+
+-- | Given a fontname returns the font structure. If the font name is
+-- not valid the default font will be loaded and returned.
+initUtf8Font :: Display -> String -> IO FontSet
+initUtf8Font dpy s = do
+ (_,_,fs) <- catch (getIt dpy) (fallBack dpy)
+ return fs
+ where getIt d = createFontSet d s
+ fallBack d = const $ createFontSet d "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*"
+
+releaseUtf8Font :: Display -> FontSet -> IO ()
+releaseUtf8Font d = freeFontSet d
+
+textWidth :: Display -> XFont -> String -> IO Int
+textWidth _ (Utf8 fs) s = return $ fi $ wcTextEscapement fs s
+textWidth _ (Core fs) s = return $ fi $ Xlib.textWidth fs s
+#ifdef XFT
+textWidth dpy (Xft xftdraw) s = do
+ gi <- xftTextExtents dpy xftdraw s
+ return $ xglyphinfo_xOff gi
+#endif
+
+textExtents :: XFont -> String -> IO (Int32,Int32)
+textExtents (Core fs) s = do
+ let (_,a,d,_) = Xlib.textExtents fs s
+ return (a,d)
+textExtents (Utf8 fs) s = do
+ let (_,rl) = wcTextExtents fs s
+ ascent = fi $ - (rect_y rl)
+ descent = fi $ rect_height rl + (fi $ rect_y rl)
+ return (ascent, descent)
+#ifdef XFT
+textExtents (Xft xftfont) _ = do
+ ascent <- fi `fmap` xftfont_ascent xftfont
+ descent <- fi `fmap` xftfont_descent xftfont
+ return (ascent, descent)
+#endif
+
+printString :: Display -> Drawable -> XFont -> GC -> String -> String
+ -> Position -> Position -> String -> IO ()
+printString d p (Core fs) gc fc bc x y s = do
+ setFont d gc $ fontFromFontStruct fs
+ [fc',bc'] <- mapM (initColor d) [fc,bc]
+ setForeground d gc fc'
+ setBackground d gc bc'
+ drawImageString d p gc x y s
+printString d p (Utf8 fs) gc fc bc x y s = do
+ [fc',bc'] <- mapM (initColor d) [fc,bc]
+ setForeground d gc fc'
+ setBackground d gc bc'
+ io $ wcDrawImageString d p fs gc x y s
+#ifdef XFT
+printString dpy drw fs@(Xft font) gc fc bc x y s = do
+ let screen = defaultScreenOfDisplay dpy
+ colormap = defaultColormapOfScreen screen
+ visual = defaultVisualOfScreen screen
+ bcolor <- initColor dpy bc
+ (a,d) <- textExtents fs s
+ gi <- xftTextExtents dpy font s
+ setForeground dpy gc bcolor
+ fillRectangle dpy drw gc (x - fi (xglyphinfo_x gi))
+ (y - fi a)
+ (fi $ xglyphinfo_xOff gi)
+ (fi $ a + d)
+ withXftDraw dpy drw visual colormap $
+ \draw -> withXftColorName dpy visual colormap fc $
+ \color -> xftDrawString draw color font x y s
+#endif
+
+-- | Get the Pixel value for a named color: if an invalid name is
+-- given the black pixel will be returned.
+initColor :: Display -> String -> IO Pixel
+initColor dpy c =
+ catch (initColor' dpy c) (const . return . blackPixel dpy $ (defaultScreen dpy))
+
+initColor' :: Display -> String -> IO Pixel
+initColor' dpy c = (color_pixel . fst) `liftM` allocNamedColor dpy colormap c
+ where colormap = defaultColormap dpy (defaultScreen dpy)
+
+-- | Creates a window with the attribute override_redirect set to True.
+-- Windows Managers should not touch this kind of windows.
+mkUnmanagedWindow :: Display
+ -> Screen
+ -> Window
+ -> Position
+ -> Position
+ -> Dimension
+ -> Dimension
+ -> Bool
+ -> IO Window
+mkUnmanagedWindow dpy scr rw x y w h o = do
+ let visual = defaultVisualOfScreen scr
+ attrmask = cWOverrideRedirect
+ allocaSetWindowAttributes $
+ \attributes -> do
+ set_override_redirect attributes o
+ createWindow dpy rw x y w h 0 (defaultDepthOfScreen scr)
+ inputOutput visual attrmask attributes
+-- | A version of nextEvent that does not block in foreign calls.
+nextEvent' :: Display -> XEventPtr -> IO ()
+nextEvent' d p = do
+ pend <- pending d
+ if pend /= 0
+ then nextEvent d p
+ else do
+ threadWaitRead (Fd fd)
+ nextEvent' d p
+ where
+ fd = connectionNumber d
+
+io :: MonadIO m => IO a -> m a
+io = liftIO
+
+-- | Short-hand for 'fromIntegral'
+fi :: (Integral a, Num b) => a -> b
+fi = fromIntegral
+
+#if defined XFT || defined UTF8
+#include <locale.h>
+foreign import ccall unsafe "locale.h setlocale"
+ setlocale :: CInt -> CString -> IO CString
+
+setupLocale :: IO ()
+setupLocale = withCString "" $ \s -> do
+ setlocale (#const LC_ALL) s
+ return ()
+#endif