{-# LANGUAGE ForeignFunctionInterface #-} ----------------------------------------------------------------------------- -- | -- Module : XUtil -- Copyright : (C) 2011, 2012, 2013, 2014, 2015 Jose Antonio Ortega Ruiz -- (C) 2007 Andrea Rossato -- License : BSD3 -- -- Maintainer : jao@gnu.org -- Stability : unstable -- Portability : unportable -- ----------------------------------------------------------------------------- module XUtil ( XFont , initFont , initCoreFont , initUtf8Font , textExtents , textWidth , printString , newWindow , nextEvent' , readFileSafe , hGetLineSafe , io , fi , XRenderPictureAttributes(..) , XRenderPictFormat(..) , XRenderColor(..) -- reexport , Picture , xRenderFindStandardFormat , xRenderCreatePicture , xRenderFillRectangle , xRenderComposite , xRenderCreateSolidFill , xRenderFreePicture , withRenderPicture , withRenderFill , drawBackground , parseRenderColor , pictOpMinimum , pictOpClear , pictOpSrc , pictOpDst , pictOpOver , pictOpOverReverse , pictOpIn , pictOpInReverse , pictOpOut , pictOpOutReverse , pictOpAtop , pictOpAtopReverse , pictOpXor , pictOpAdd , pictOpSaturate , pictOpMaximum ) where import Control.Concurrent import Control.Monad (when) import Control.Monad.Trans import Control.Exception (SomeException, handle) 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 import Foreign.C #if defined XFT || defined UTF8 # if __GLASGOW_HASKELL__ < 612 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 MinXft import Graphics.X11.Xrender #endif import ColorCache 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 [AXftFont] #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 miscFixedFont :: String miscFixedFont = "-misc-fixed-*-*-*-*-*-*-*-*-*-*-*-*" -- | 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 <- handle fallBack getIt addFinalizer f (freeFont d f) return f where getIt = loadQueryFont d s fallBack :: SomeException -> IO FontStruct fallBack = const $ loadQueryFont d miscFixedFont -- | 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) <- handle fallBack getIt addFinalizer f (freeFontSet d f) return f where getIt = createFontSet d s fallBack :: SomeException -> IO ([String], String, FontSet) fallBack = const $ createFontSet d miscFixedFont #ifdef XFT initXftFont :: Display -> String -> IO [AXftFont] initXftFont d s = do setupLocale let fontNames = wordsBy (== ',') (drop 4 s) fonts <- mapM openFont fontNames return fonts where openFont fontName = do f <- openAXftFont d (defaultScreenOfDisplay d) fontName addFinalizer f (closeAXftFont d f) return f wordsBy p str = case dropWhile p str of "" -> [] str' -> w : wordsBy p str'' where (w, str'') = break p str' #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 <- xftTxtExtents' 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 xftfonts) _ = do ascent <- fi `fmap` xft_ascent' xftfonts descent <- fi `fmap` xft_descent' xftfonts return (ascent, descent) #endif printString :: Display -> Drawable -> XFont -> GC -> String -> String -> Position -> Position -> String -> Int -> IO () printString d p (Core fs) gc fc bc x y s a = do setFont d gc $ fontFromFontStruct fs withColors d [fc, bc] $ \[fc', bc'] -> do setForeground d gc fc' when (a == 255) (setBackground d gc bc') drawImageString d p gc x y s printString d p (Utf8 fs) gc fc bc x y s a = withColors d [fc, bc] $ \[fc', bc'] -> do setForeground d gc fc' when (a == 255) (setBackground d gc bc') io $ wcDrawImageString d p fs gc x y s #ifdef XFT printString dpy drw fs@(Xft fonts) _ fc bc x y s al = do withDrawingColors dpy drw fc bc $ \draw -> \fc' -> \bc' -> do when (al == 255) $ do (a,d) <- textExtents fs s gi <- xftTxtExtents dpy (head fonts) s drawXftRect draw bc' (x + 1 - fi (xglyphinfo_x gi)) (y - (a + d) + 1) (xglyphinfo_xOff gi) (a + d) (drawXftString' draw fc' fonts (toInteger x) (toInteger (y - 2)) s) #endif -- | 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 = if o then cWOverrideRedirect else 0 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 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 -- More XRender nonsense #include type Picture = XID type PictOp = CInt foreign import ccall unsafe "X11/extensions/Xrender.h XRenderFillRectangle" xRenderFillRectangle :: Display -> PictOp -> Picture -> Ptr XRenderColor -> CInt -> CInt -> CUInt -> CUInt -> IO () foreign import ccall unsafe "X11/extensions/Xrender.h XRenderComposite" xRenderComposite :: Display -> PictOp -> Picture -> Picture -> Picture -> CInt -> CInt -> CInt -> CInt -> CInt -> CInt -> CUInt -> CUInt -> IO () foreign import ccall unsafe "X11/extensions/Xrender.h XRenderCreateSolidFill" xRenderCreateSolidFill :: Display -> Ptr XRenderColor -> IO Picture foreign import ccall unsafe "X11/extensions/Xrender.h XRenderFreePicture" xRenderFreePicture :: Display -> Picture -> IO () foreign import ccall unsafe "string.h" memset :: Ptr a -> CInt -> CSize -> IO () foreign import ccall unsafe "X11/extensions/Xrender.h XRenderFindStandardFormat" xRenderFindStandardFormat :: Display -> CInt -> IO (Ptr XRenderPictFormat) foreign import ccall unsafe "X11/extensions/Xrender.h XRenderCreatePicture" xRenderCreatePicture :: Display -> Drawable -> Ptr XRenderPictFormat -> CULong -> Ptr XRenderPictureAttributes -> IO Picture data XRenderPictFormat = XRenderPictFormat data XRenderPictureAttributes = XRenderPictureAttributes -- Attributes not supported instance Storable XRenderPictureAttributes where sizeOf _ = #{size XRenderPictureAttributes} alignment _ = alignment (undefined :: CInt) peek _ = return XRenderPictureAttributes poke p XRenderPictureAttributes = do memset p 0 #{size XRenderPictureAttributes} -- | Convenience function, gives us an XRender handle to a traditional -- Pixmap. Don't let it escape. withRenderPicture :: Display -> Drawable -> (Picture -> IO a) -> IO () withRenderPicture d p f = do format <- xRenderFindStandardFormat d 1 -- PictStandardRGB24 alloca $ \attr -> do pic <- xRenderCreatePicture d p format 0 attr f pic xRenderFreePicture d pic -- | Convenience function, gives us an XRender picture that is a solid -- fill of color 'c'. Don't let it escape. withRenderFill :: Display -> XRenderColor -> (Picture -> IO a) -> IO () withRenderFill d c f = do pic <- with c (xRenderCreateSolidFill d) f pic xRenderFreePicture d pic -- | Drawing the background to a pixmap and tacking into account -- transparency drawBackground :: Display -> Drawable -> String -> Int -> Rectangle -> IO () drawBackground d p bgc alpha (Rectangle x y wid ht) = do let render opt bg pic m = xRenderComposite d opt bg m pic (fromIntegral x) (fromIntegral y) 0 0 0 0 (fromIntegral wid) (fromIntegral ht) withRenderPicture d p $ \pic -> do -- Handle background color bgcolor <- parseRenderColor d bgc withRenderFill d bgcolor $ \bgfill -> withRenderFill d (XRenderColor 0 0 0 (257 * alpha)) (render pictOpSrc bgfill pic) -- Handle transparency internAtom d "_XROOTPMAP_ID" False >>= \xid -> let xroot = defaultRootWindow d in alloca $ \x1 -> alloca $ \x2 -> alloca $ \x3 -> alloca $ \x4 -> alloca $ \pprop -> do xGetWindowProperty d xroot xid 0 1 False 20 x1 x2 x3 x4 pprop prop <- peek pprop when (prop /= nullPtr) $ do rootbg <- peek (castPtr prop) :: IO Pixmap xFree prop withRenderPicture d rootbg $ \bgpic -> withRenderFill d (XRenderColor 0 0 0 (0xFFFF - 257 * alpha)) (render pictOpAdd bgpic pic) -- | Parses color into XRender color (allocation not necessary!) parseRenderColor :: Display -> String -> IO XRenderColor parseRenderColor d c = do let colormap = defaultColormap d (defaultScreen d) Color _ red green blue _ <- parseColor d colormap c return $ XRenderColor (fromIntegral red) (fromIntegral green) (fromIntegral blue) 0xFFFF pictOpMinimum, pictOpClear, pictOpSrc, pictOpDst, pictOpOver, pictOpOverReverse, pictOpIn, pictOpInReverse, pictOpOut, pictOpOutReverse, pictOpAtop, pictOpAtopReverse, pictOpXor, pictOpAdd, pictOpSaturate, pictOpMaximum :: PictOp pictOpMinimum = 0 pictOpClear = 0 pictOpSrc = 1 pictOpDst = 2 pictOpOver = 3 pictOpOverReverse = 4 pictOpIn = 5 pictOpInReverse = 6 pictOpOut = 7 pictOpOutReverse = 8 pictOpAtop = 9 pictOpAtopReverse = 10 pictOpXor = 11 pictOpAdd = 12 pictOpSaturate = 13 pictOpMaximum = 13