summaryrefslogtreecommitdiffhomepage
path: root/XUtil.hsc
diff options
context:
space:
mode:
Diffstat (limited to 'XUtil.hsc')
-rw-r--r--XUtil.hsc259
1 files changed, 0 insertions, 259 deletions
diff --git a/XUtil.hsc b/XUtil.hsc
deleted file mode 100644
index d5bb591..0000000
--- a/XUtil.hsc
+++ /dev/null
@@ -1,259 +0,0 @@
-{-# OPTIONS -fglasgow-exts #-}
------------------------------------------------------------------------------
--- |
--- Module : XUtil
--- Copyright : (C) 2007 Andrea Rossato
--- License : BSD3
---
--- Maintainer : andrea.rossato@unitn.it
--- Stability : unstable
--- Portability : unportable
---
------------------------------------------------------------------------------
-
-module XUtil
- ( XFont
- , initFont
- , initCoreFont
- , initUtf8Font
- , textExtents
- , textWidth
- , printString
- , initColor
- , newWindow
- , nextEvent'
- , readFileSafe
- , hGetLineSafe
- , io
- , fi
- , withColors
- , DynPixel(..)
- ) where
-
-import Control.Concurrent
-import Control.Monad.Trans
-import Data.IORef
-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.Mem.Weak ( addFinalizer )
-import System.Posix.Types (Fd(..))
-import System.IO
-#if defined XFT || defined UTF8
-# if __GLASGOW_HASKELL__ < 612
-import Foreign.C
-import qualified System.IO.UTF8 as UTF8 (readFile,hGetLine)
-# else
-import qualified System.IO as UTF8 (readFile,hGetLine)
-# endif
-#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
- let xftPrefix = "xft:" in
- if xftPrefix `isPrefixOf` s then
- fmap Xft $ initXftFont d s
- else
-#endif
-#if defined UTF8 || __GLASGOW_HASKELL__ >= 612
- fmap Utf8 $ initUtf8Font d s
-#else
- fmap Core $ initCoreFont d s
-#endif
-
--- | 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 d s = do
- f <- catch getIt fallBack
- addFinalizer f (freeFont d f)
- return f
- where getIt = loadQueryFont d s
- fallBack = const $ loadQueryFont d "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*"
-
--- | 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 d s = do
- setupLocale
- (_,_,f) <- catch getIt fallBack
- addFinalizer f (freeFontSet d f)
- return f
- where getIt = createFontSet d s
- fallBack = const $ createFontSet d "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*"
-
-#ifdef XFT
-initXftFont :: Display -> String -> IO XftFont
-initXftFont d s = do
- setupLocale
- f <- xftFontOpen d (defaultScreenOfDisplay d) (drop 4 s)
- addFinalizer f (xftFontClose d f)
- return f
-#endif
-
-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
- withColors d [fc, bc] $ \[fc', bc'] -> do
- 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 =
- withColors d [fc, bc] $ \[fc', bc'] -> do
- 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
- withColors dpy [bc] $ \[bcolor] -> do
- (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 + d))
- (fi $ xglyphinfo_xOff gi)
- (fi $ 4 + a + d)
- withXftDraw dpy drw visual colormap $
- \draw -> withXftColorName dpy visual colormap fc $
- \color -> xftDrawString draw color font x (y - 2) s
-#endif
-
-data DynPixel = DynPixel { allocated :: Bool
- , pixel :: Pixel
- }
-
--- | Get the Pixel value for a named color: if an invalid name is
--- given the black pixel will be returned.
-initColor :: Display -> String -> IO DynPixel
-initColor dpy c = (initColor' dpy c) `catch`
- (const . return $ DynPixel False (blackPixel dpy $ defaultScreen dpy))
-
-type ColorCache = [(String, Color)]
-{-# NOINLINE colorCache #-}
-colorCache :: IORef ColorCache
-colorCache = unsafePerformIO $ newIORef []
-
-getCachedColor :: String -> IO (Maybe Color)
-getCachedColor color_name = lookup color_name `fmap` readIORef colorCache
-
-putCachedColor :: String -> Color -> IO ()
-putCachedColor name c_id = modifyIORef colorCache $ \c -> (name, c_id) : c
-
-initColor' :: Display -> String -> IO DynPixel
-initColor' dpy c = do
- let colormap = defaultColormap dpy (defaultScreen dpy)
- cached_color <- getCachedColor c
- c' <- case cached_color of
- Just col -> return col
- _ -> do (c'', _) <- allocNamedColor dpy colormap c
- putCachedColor c c''
- return c''
- return $ DynPixel True (color_pixel c')
-
-withColors :: MonadIO m => Display -> [String] -> ([Pixel] -> m a) -> m a
-withColors d cs f = do
- ps <- mapM (io . initColor d) cs
- f $ map pixel ps
-
--- | Creates a window with the attribute override_redirect set to True.
--- Windows Managers should not touch this kind of windows.
-newWindow :: Display -> Screen -> Window -> Rectangle -> Bool -> IO Window
-newWindow dpy scr rw (Rectangle 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 __GLASGOW_HASKELL__ < 612 && (defined XFT || defined UTF8)
-#include <locale.h>
-foreign import ccall unsafe "locale.h setlocale"
- setlocale :: CInt -> CString -> IO CString
-
-setupLocale :: IO ()
-setupLocale = withCString "" (setlocale $ #const LC_ALL) >> return ()
-# else
-setupLocale :: IO ()
-setupLocale = return ()
-#endif