X11-extras (empty) → 0.0
raw patch · 10 files changed
+955/−0 lines, 10 filesdep +X11dep +basebuild-type:Customsetup-changed
Dependencies added: X11, base
Files
- Graphics/X11/Xinerama.hsc +129/−0
- Graphics/X11/Xlib/Extras.hsc +660/−0
- LICENSE +27/−0
- README +12/−0
- Setup.lhs +3/−0
- X11-extras.buildinfo.in +3/−0
- X11-extras.cabal +29/−0
- cbits/XUtils.c +31/−0
- configure.ac +24/−0
- include/XlibExtras.h +37/−0
+ Graphics/X11/Xinerama.hsc view
@@ -0,0 +1,129 @@+-- | Interface to Xinerama API+module Graphics.X11.Xinerama+ (XineramaScreenInfo(..), + xineramaIsActive, + xineramaQueryExtension, + xineramaQueryVersion, + xineramaQueryScreens,+ getScreenInfo) where++#include <config.h>++import Foreign+import Foreign.C.Types+import Graphics.X11.Xlib+import Control.Monad++-- | Representation of the XineramaScreenInfo struct+data XineramaScreenInfo = XineramaScreenInfo + { xsi_screen_number :: CInt,+ xsi_x_org :: CShort,+ xsi_y_org :: CShort,+ xsi_width :: CShort,+ xsi_height :: CShort }+ deriving (Show)++-- | Wrapper around xineramaQueryScreens that fakes a single screen when+-- Xinerama is not active. This is the preferred interface to+-- Graphics.X11.Xinerama.+getScreenInfo :: Display -> IO [Rectangle]+getScreenInfo dpy = maybe [singleScreen] (map xsiToRect) `liftM` xineramaQueryScreens dpy+ where dflt = defaultScreen dpy+ xsiToRect xsi = Rectangle+ { rect_x = fromIntegral $ xsi_x_org xsi+ , rect_y = fromIntegral $ xsi_y_org xsi+ , rect_width = fromIntegral $ xsi_width xsi+ , rect_height = fromIntegral $ xsi_height xsi+ }+ singleScreen = Rectangle+ { rect_x = 0 + , rect_y = 0 + , rect_width = fromIntegral $ displayWidth dpy dflt+ , rect_height = fromIntegral $ displayHeight dpy dflt+ }++#ifdef HAVE_X11_EXTENSIONS_XINERAMA_H+-- We have Xinerama, so the library will actually work++-- for XFree() (already included from Xinerama.h, but I don't know if I can count on that.)+#include <X11/Xlib.h>++#include <X11/extensions/Xinerama.h>++instance Storable XineramaScreenInfo where+ sizeOf _ = #{size XineramaScreenInfo}+ -- FIXME: Is this right?+ alignment _ = alignment (undefined :: CInt)++ poke p xsi = do+ #{poke XineramaScreenInfo, screen_number } p $ xsi_screen_number xsi+ #{poke XineramaScreenInfo, x_org } p $ xsi_x_org xsi+ #{poke XineramaScreenInfo, y_org } p $ xsi_y_org xsi+ #{poke XineramaScreenInfo, width } p $ xsi_width xsi+ #{poke XineramaScreenInfo, height } p $ xsi_height xsi++ peek p = return XineramaScreenInfo+ `ap` (#{peek XineramaScreenInfo, screen_number} p)+ `ap` (#{peek XineramaScreenInfo, x_org} p)+ `ap` (#{peek XineramaScreenInfo, y_org} p)+ `ap` (#{peek XineramaScreenInfo, width} p)+ `ap` (#{peek XineramaScreenInfo, height} p)++foreign import ccall "XineramaIsActive"+ xineramaIsActive :: Display -> IO Bool++xineramaQueryExtension :: Display -> IO (Maybe (CInt, CInt))+xineramaQueryExtension dpy = wrapPtr2 (cXineramaQueryExtension dpy) go+ where go False _ _ = Nothing+ go True eventbase errorbase = Just (fromIntegral eventbase, fromIntegral errorbase)++xineramaQueryVersion :: Display -> IO (Maybe (CInt, CInt))+xineramaQueryVersion dpy = wrapPtr2 (cXineramaQueryVersion dpy) go+ where go False _ _ = Nothing+ go True major minor = Just (fromIntegral major, fromIntegral minor)++xineramaQueryScreens :: Display -> IO (Maybe [XineramaScreenInfo])+xineramaQueryScreens dpy = + withPool $ \pool -> do intp <- pooledMalloc pool+ p <- cXineramaQueryScreens dpy intp+ if p == nullPtr + then return Nothing+ else do nscreens <- peek intp+ screens <- peekArray (fromIntegral nscreens) p+ cXFree p+ return (Just screens)++foreign import ccall "XineramaQueryExtension"+ cXineramaQueryExtension :: Display -> Ptr CInt -> Ptr CInt -> IO Bool+foreign import ccall "XineramaQueryVersion"+ cXineramaQueryVersion :: Display -> Ptr CInt -> Ptr CInt -> IO Bool+foreign import ccall "XineramaQueryScreens"+ cXineramaQueryScreens :: Display -> Ptr CInt -> IO (Ptr XineramaScreenInfo)+foreign import ccall "XFree"+ cXFree :: Ptr a -> IO CInt++wrapPtr2 :: (Storable a, Storable b) => (Ptr a -> Ptr b -> IO c) -> (c -> a -> b -> d) -> IO d+wrapPtr2 cfun f = + withPool $ \pool -> do aptr <- pooledMalloc pool+ bptr <- pooledMalloc pool+ ret <- cfun aptr bptr+ a <- peek aptr+ b <- peek bptr+ return (f ret a b)++#else++-- No Xinerama, but if we fake a non-active Xinerama interface, "getScreenInfo"+-- will continue to work fine in the single-screen case.+xineramaIsActive :: Display -> IO Bool+xineramaIsActive _ = return False++xineramaQueryExtension :: Display -> IO (Maybe (CInt, CInt))+xineramaQueryExtension _ = return Nothing++xineramaQueryVersion :: Display -> IO (Maybe (CInt, CInt))+xineramaQueryVersion _ = return Nothing++xineramaQueryScreens :: Display -> IO (Maybe [XineramaScreenInfo])+xineramaQueryScreens _ = return Nothing+#endif
+ Graphics/X11/Xlib/Extras.hsc view
@@ -0,0 +1,660 @@+-----------------------------------------------------------------------------+-- |+-- Module :+-- Copyright : (c) Spencer Janssen+-- License : BSD3-style (see LICENSE)+-- +-- Stability : stable+--+-----------------------------------------------------------------------------+--+-- missing functionality from the X11 library+--++module Graphics.X11.Xlib.Extras where++import Graphics.X11.Xlib+import Graphics.X11.Xlib.Types+import Graphics.X11.Xlib.Misc+import Foreign+import Foreign.C.Types+import Control.Monad++#include "XlibExtras.h"++data Event+ = AnyEvent+ { ev_event_type :: !EventType+ , ev_serial :: !CULong+ , ev_send_event :: !Bool+ , ev_event_display :: Display+ , ev_window :: !Window+ }+ | ConfigureRequestEvent+ { ev_event_type :: !EventType+ , ev_serial :: !CULong+ , ev_send_event :: !Bool+ , ev_event_display :: Display+ , ev_parent :: !Window+ , ev_window :: !Window+ , ev_x :: !CInt+ , ev_y :: !CInt+ , ev_width :: !CInt+ , ev_height :: !CInt+ , ev_border_width :: !CInt+ , ev_above :: !Window+ , ev_detail :: !NotifyDetail+ , ev_value_mask :: !CULong+ }+ | MapRequestEvent+ { ev_event_type :: !EventType+ , ev_serial :: !CULong+ , ev_send_event :: !Bool+ , ev_event_display :: Display+ , ev_parent :: !Window+ , ev_window :: !Window+ }+ | KeyEvent+ { ev_event_type :: !EventType+ , ev_serial :: !CULong+ , ev_send_event :: !Bool+ , ev_event_display :: Display+ , ev_window :: !Window+ , ev_root :: !Window+ , ev_subwindow :: !Window+ , ev_time :: !Time+ , ev_x :: !CInt+ , ev_y :: !CInt+ , ev_x_root :: !CInt+ , ev_y_root :: !CInt+ , ev_state :: !KeyMask+ , ev_keycode :: !KeyCode+ , ev_same_screen :: !Bool+ }+ | ButtonEvent+ { ev_event_type :: !EventType+ , ev_serial :: !CULong+ , ev_send_event :: !Bool+ , ev_event_display :: Display+ , ev_window :: !Window+ , ev_root :: !Window+ , ev_subwindow :: !Window+ , ev_time :: !Time+ , ev_x :: !CInt+ , ev_y :: !CInt+ , ev_x_root :: !CInt+ , ev_y_root :: !CInt+ , ev_state :: !KeyMask+ , ev_button :: !Button+ , ev_same_screen :: !Bool+ }+ | DestroyWindowEvent+ { ev_event_type :: !EventType+ , ev_serial :: !CULong+ , ev_send_event :: !Bool+ , ev_event_display :: Display+ , ev_event :: !Window+ , ev_window :: !Window+ }+ | UnmapEvent+ { ev_event_type :: !EventType+ , ev_serial :: !CULong+ , ev_send_event :: !Bool+ , ev_event_display :: Display+ , ev_event :: !Window+ , ev_window :: !Window+ , ev_from_configure :: !Bool+ }+ | MapNotifyEvent+ { ev_event_type :: !EventType+ , ev_serial :: !CULong+ , ev_send_event :: !Bool+ , ev_event_display :: Display+ , ev_event :: !Window+ , ev_window :: !Window+ , ev_override_redirect :: !Bool+ }+ | MappingNotifyEvent+ { ev_event_type :: !EventType+ , ev_serial :: !CULong+ , ev_send_event :: !Bool+ , ev_event_display :: Display+ , ev_window :: !Window+ , ev_request :: !MappingRequest+ , ev_first_keycode :: !KeyCode+ , ev_count :: !CInt+ }+ | CrossingEvent+ { ev_event_type :: !EventType+ , ev_serial :: !CULong+ , ev_send_event :: !Bool+ , ev_event_display :: Display+ , ev_window :: !Window+ , ev_root :: !Window+ , ev_subwindow :: !Window+ , ev_time :: !Time+ , ev_x :: !CInt+ , ev_y :: !CInt+ , ev_x_root :: !CInt+ , ev_y_root :: !CInt+ , ev_mode :: !NotifyMode+ , ev_detail :: !NotifyDetail+ , ev_same_screen :: !Bool+ , ev_focus :: !Bool+ , ev_state :: !Modifier+ }++ deriving Show++eventTable =+ [ (keyPress , "KeyPress")+ , (keyRelease , "KeyRelease")+ , (buttonPress , "ButtonPress")+ , (buttonRelease , "ButtonRelease")+ , (motionNotify , "MotionNotify")+ , (enterNotify , "EnterNotify")+ , (leaveNotify , "LeaveNotify")+ , (focusIn , "FocusIn")+ , (focusOut , "FocusOut")+ , (keymapNotify , "KeymapNotify")+ , (expose , "Expose")+ , (graphicsExpose , "GraphicsExpose")+ , (noExpose , "NoExpose")+ , (visibilityNotify , "VisibilityNotify")+ , (createNotify , "CreateNotify")+ , (destroyNotify , "DestroyNotify")+ , (unmapNotify , "UnmapNotify")+ , (mapNotify , "MapNotify")+ , (mapRequest , "MapRequest")+ , (reparentNotify , "ReparentNotify")+ , (configureNotify , "ConfigureNotify")+ , (configureRequest , "ConfigureRequest")+ , (gravityNotify , "GravityNotify")+ , (resizeRequest , "ResizeRequest")+ , (circulateNotify , "CirculateNotify")+ , (circulateRequest , "CirculateRequest")+ , (propertyNotify , "PropertyNotify")+ , (selectionClear , "SelectionClear")+ , (selectionRequest , "SelectionRequest")+ , (selectionNotify , "SelectionNotify")+ , (colormapNotify , "ColormapNotify")+ , (clientMessage , "ClientMessage")+ , (mappingNotify , "MappingNotify")+ , (lASTEvent , "LASTEvent")+ ]++eventName :: Event -> String+eventName e = maybe ("unknown " ++ show x) id $ lookup x eventTable+ where x = fromIntegral $ ev_event_type e++getEvent :: XEventPtr -> IO Event+getEvent p = do+ -- All events share this layout and naming convention, there is also a+ -- common Window field, but the names for this field vary.+ type_ <- #{peek XAnyEvent, type} p+ serial <- #{peek XAnyEvent, serial} p+ send_event <- #{peek XAnyEvent, send_event} p+ display <- fmap Display (#{peek XAnyEvent, display} p)+ case () of++ -------------------------+ -- ConfigureRequestEvent:+ -------------------------+ _ | type_ == configureRequest -> do+ parent <- #{peek XConfigureRequestEvent, parent } p+ window <- #{peek XConfigureRequestEvent, window } p+ x <- #{peek XConfigureRequestEvent, x } p+ y <- #{peek XConfigureRequestEvent, y } p+ width <- #{peek XConfigureRequestEvent, width } p+ height <- #{peek XConfigureRequestEvent, height } p+ border_width <- #{peek XConfigureRequestEvent, border_width} p+ above <- #{peek XConfigureRequestEvent, above } p+ detail <- #{peek XConfigureRequestEvent, detail } p+ value_mask <- #{peek XConfigureRequestEvent, value_mask } p+ return $ ConfigureRequestEvent+ { ev_event_type = type_+ , ev_serial = serial+ , ev_send_event = send_event+ , ev_event_display = display+ , ev_parent = parent+ , ev_window = window+ , ev_x = x+ , ev_y = y+ , ev_width = width+ , ev_height = height+ , ev_border_width = border_width+ , ev_above = above+ , ev_detail = detail+ , ev_value_mask = value_mask+ }++ -------------------+ -- MapRequestEvent:+ -------------------+ | type_ == mapRequest -> do+ parent <- #{peek XMapRequestEvent, parent} p+ window <- #{peek XMapRequestEvent, window} p+ return $ MapRequestEvent+ { ev_event_type = type_+ , ev_serial = serial+ , ev_send_event = send_event+ , ev_event_display = display+ , ev_parent = parent+ , ev_window = window+ }++ -------------------+ -- MapNotifyEvent+ -------------------+ | type_ == mapNotify -> do+ event <- #{peek XMapEvent, event} p+ window <- #{peek XMapEvent, window} p+ override_redirect <- #{peek XMapEvent, override_redirect} p+ return $ MapNotifyEvent+ { ev_event_type = type_+ , ev_serial = serial+ , ev_send_event = send_event+ , ev_event_display = display+ , ev_event = event+ , ev_window = window+ , ev_override_redirect = override_redirect+ }++ -------------------+ -- MappingNotifyEvent+ -------------------+ | type_ == mappingNotify -> do+ window <- #{peek XMappingEvent,window} p+ request <- #{peek XMappingEvent,request} p+ first_keycode <- #{peek XMappingEvent,first_keycode} p+ count <- #{peek XMappingEvent,count} p++ return $ MappingNotifyEvent+ { ev_event_type = type_+ , ev_serial = serial+ , ev_send_event = send_event+ , ev_event_display = display+ , ev_window = window+ , ev_request = request+ , ev_first_keycode = first_keycode+ , ev_count = count+ }++ ------------+ -- KeyEvent:+ ------------+ | type_ == keyPress || type_ == keyRelease -> do+ window <- #{peek XKeyEvent, window } p+ root <- #{peek XKeyEvent, root } p+ subwindow <- #{peek XKeyEvent, subwindow } p+ time <- #{peek XKeyEvent, time } p+ x <- #{peek XKeyEvent, x } p+ y <- #{peek XKeyEvent, y } p+ x_root <- #{peek XKeyEvent, x_root } p+ y_root <- #{peek XKeyEvent, y_root } p+ state <- (#{peek XKeyEvent, state } p) :: IO CUInt+ keycode <- #{peek XKeyEvent, keycode } p+ same_screen <- #{peek XKeyEvent, same_screen} p+ return $ KeyEvent+ { ev_event_type = type_+ , ev_serial = serial+ , ev_send_event = send_event+ , ev_event_display = display+ , ev_window = window+ , ev_root = root+ , ev_subwindow = subwindow+ , ev_time = time+ , ev_x = x+ , ev_y = y+ , ev_x_root = x_root+ , ev_y_root = y_root+ , ev_state = fromIntegral state+ , ev_keycode = keycode+ , ev_same_screen = same_screen+ }++ ---------------+ -- ButtonEvent:+ ---------------+ | type_ == buttonPress || type_ == buttonRelease -> do++ window <- #{peek XButtonEvent, window } p+ root <- #{peek XButtonEvent, root } p+ subwindow <- #{peek XButtonEvent, subwindow } p+ time <- #{peek XButtonEvent, time } p+ x <- #{peek XButtonEvent, x } p+ y <- #{peek XButtonEvent, y } p+ x_root <- #{peek XButtonEvent, x_root } p+ y_root <- #{peek XButtonEvent, y_root } p+ state <- (#{peek XButtonEvent, state } p) :: IO CUInt+ button <- #{peek XButtonEvent, button } p+ same_screen <- #{peek XButtonEvent, same_screen} p++ return $ ButtonEvent+ { ev_event_type = type_+ , ev_serial = serial+ , ev_send_event = send_event+ , ev_event_display = display+ , ev_window = window+ , ev_root = root+ , ev_subwindow = subwindow+ , ev_time = time+ , ev_x = x+ , ev_y = y+ , ev_x_root = x_root+ , ev_y_root = y_root+ , ev_state = fromIntegral state+ , ev_button = button+ , ev_same_screen = same_screen+ }++ ----------------------+ -- DestroyWindowEvent:+ ----------------------+ | type_ == destroyNotify -> do+ event <- #{peek XDestroyWindowEvent, event } p+ window <- #{peek XDestroyWindowEvent, window} p+ return $ DestroyWindowEvent+ { ev_event_type = type_+ , ev_serial = serial+ , ev_send_event = send_event+ , ev_event_display = display+ , ev_event = event+ , ev_window = window+ }+++ --------------------+ -- UnmapNotifyEvent:+ --------------------+ | type_ == unmapNotify -> do+ event <- #{peek XUnmapEvent, event } p+ window <- #{peek XUnmapEvent, window } p+ from_configure <- #{peek XUnmapEvent, from_configure} p+ return $ UnmapEvent+ { ev_event_type = type_+ , ev_serial = serial+ , ev_send_event = send_event+ , ev_event_display = display+ , ev_event = event+ , ev_window = window+ , ev_from_configure = from_configure+ }++ --------------------+ -- CrossingEvent+ --------------------+ | type_ == enterNotify || type_ == leaveNotify -> do+ window <- #{peek XCrossingEvent, window } p+ root <- #{peek XCrossingEvent, root } p+ subwindow <- #{peek XCrossingEvent, subwindow } p+ time <- #{peek XCrossingEvent, time } p+ x <- #{peek XCrossingEvent, x } p+ y <- #{peek XCrossingEvent, y } p+ x_root <- #{peek XCrossingEvent, x_root } p+ y_root <- #{peek XCrossingEvent, y_root } p+ mode <- #{peek XCrossingEvent, mode } p+ detail <- #{peek XCrossingEvent, detail } p+ same_screen <- #{peek XCrossingEvent, same_screen } p+ focus <- #{peek XCrossingEvent, focus } p+ state <- (#{peek XCrossingEvent, state } p) :: IO CUInt++ return $ CrossingEvent+ { ev_event_type = type_+ , ev_serial = serial+ , ev_send_event = send_event+ , ev_event_display = display+ , ev_window = window+ , ev_root = root+ , ev_subwindow = subwindow+ , ev_time = time+ , ev_x = x+ , ev_y = y+ , ev_x_root = x_root+ , ev_y_root = y_root+ , ev_mode = mode+ , ev_detail = detail+ , ev_same_screen = same_screen+ , ev_focus = focus+ , ev_state = fromIntegral state+ }++ -- We don't handle this event specifically, so return the generic+ -- AnyEvent.+ | otherwise -> do+ window <- #{peek XAnyEvent, window} p+ return $ AnyEvent+ { ev_event_type = type_+ , ev_serial = serial+ , ev_send_event = send_event+ , ev_event_display = display+ , ev_window = window+ }++data WindowChanges = WindowChanges+ { wc_x :: CInt+ , wc_y :: CInt+ , wc_width :: CInt+ , wc_height:: CInt+ , wc_border_width :: CInt+ , wc_sibling :: Window+ , wc_stack_mode :: CInt+ }++instance Storable WindowChanges where+ sizeOf _ = #{size XWindowChanges}++ -- I really hope this is right:+ alignment _ = alignment (undefined :: CInt)++ poke p wc = do+ #{poke XWindowChanges, x } p $ wc_x wc+ #{poke XWindowChanges, y } p $ wc_y wc+ #{poke XWindowChanges, width } p $ wc_width wc+ #{poke XWindowChanges, height } p $ wc_height wc+ #{poke XWindowChanges, border_width} p $ wc_border_width wc+ #{poke XWindowChanges, sibling } p $ wc_sibling wc+ #{poke XWindowChanges, stack_mode } p $ wc_stack_mode wc+ + peek p = return WindowChanges+ `ap` (#{peek XWindowChanges, x} p)+ `ap` (#{peek XWindowChanges, y} p)+ `ap` (#{peek XWindowChanges, width} p)+ `ap` (#{peek XWindowChanges, height} p)+ `ap` (#{peek XWindowChanges, border_width} p)+ `ap` (#{peek XWindowChanges, sibling} p)+ `ap` (#{peek XWindowChanges, stack_mode} p)++--+-- Some extra constants+--++none :: XID+none = #{const None}++anyButton :: Button+anyButton = #{const AnyButton}++--+-- The use of Int rather than CInt isn't 64 bit clean.+--++foreign import ccall unsafe "XlibExtras.h XConfigureWindow"+ xConfigureWindow :: Display -> Window -> CULong -> Ptr WindowChanges -> IO CInt++foreign import ccall unsafe "XlibExtras.h XKillClient"+ killClient :: Display -> Window -> IO CInt++configureWindow :: Display -> Window -> CULong -> WindowChanges -> IO ()+configureWindow d w m c = do+ with c (xConfigureWindow d w m)+ return ()++foreign import ccall unsafe "XlibExtras.h XFree"+ xFree :: Ptr a -> IO CInt++foreign import ccall unsafe "XlibExtras.h XQueryTree"+ xQueryTree :: Display -> Window -> Ptr Window -> Ptr Window -> Ptr (Ptr Window) -> Ptr CInt -> IO Status++queryTree :: Display -> Window -> IO (Window, Window, [Window])+queryTree d w =+ alloca $ \root_return ->+ alloca $ \parent_return ->+ alloca $ \children_return ->+ alloca $ \nchildren_return -> do+ xQueryTree d w root_return parent_return children_return nchildren_return+ p <- peek children_return+ n <- fmap fromIntegral $ peek nchildren_return+ ws <- peekArray n p+ xFree p+ liftM3 (,,) (peek root_return) (peek parent_return) (return ws)++-- TODO: this data type is incomplete wrt. the C struct+data WindowAttributes = WindowAttributes+ { wa_x, wa_y, wa_width, wa_height, wa_border_width :: CInt+ , wa_map_state :: CInt+ , wa_override_redirect :: Bool+ }++instance Storable WindowAttributes where+ -- this might be incorrect+ alignment _ = alignment (undefined :: CInt)+ sizeOf _ = #{size XWindowAttributes}+ peek p = return WindowAttributes+ `ap` (#{peek XWindowAttributes, x } p)+ `ap` (#{peek XWindowAttributes, y } p)+ `ap` (#{peek XWindowAttributes, width } p)+ `ap` (#{peek XWindowAttributes, height } p)+ `ap` (#{peek XWindowAttributes, border_width } p)+ `ap` (#{peek XWindowAttributes, map_state } p)+ `ap` (#{peek XWindowAttributes, override_redirect} p)+ poke p wa = do+ #{poke XWindowAttributes, x } p $ wa_x wa+ #{poke XWindowAttributes, y } p $ wa_y wa+ #{poke XWindowAttributes, width } p $ wa_width wa+ #{poke XWindowAttributes, height } p $ wa_height wa+ #{poke XWindowAttributes, border_width } p $ wa_border_width wa+ #{poke XWindowAttributes, map_state } p $ wa_map_state wa+ #{poke XWindowAttributes, override_redirect} p $ wa_override_redirect wa++foreign import ccall unsafe "XlibExtras.h XGetWindowAttributes"+ xGetWindowAttributes :: Display -> Window -> Ptr (WindowAttributes) -> IO Status++getWindowAttributes d w = alloca $ \p -> do+ xGetWindowAttributes d w p+ peek p++waIsViewable :: CInt+waIsViewable = fromIntegral $ #{const IsViewable}++-- | Run an action with the server+withServer :: Display -> IO () -> IO ()+withServer dpy f = do+ grabServer dpy+ f+ ungrabServer dpy++------------------------------------------------------------------------+-- setWMProtocols :: Display -> Window -> [Atom] -> IO ()++{-+setWMProtocols :: Display -> Window -> [Atom] -> IO ()+setWMProtocols display w protocols =+ withArray protocols $ \ protocol_array ->+ xSetWMProtocols display w protocol_array (length protocols)+foreign import ccall unsafe "HsXlib.h XSetWMProtocols"+ xSetWMProtocols :: Display -> Window -> Ptr Atom -> CInt -> IO ()+-}++-- | The XGetWMProtocols function returns the list of atoms+-- stored in the WM_PROTOCOLS property on the specified win+-- dow. These atoms describe window manager protocols in+-- which the owner of this window is willing to participate.+-- If the property exists, is of type ATOM, is of format 32,+-- and the atom WM_PROTOCOLS can be interned, XGetWMProtocols+-- sets the protocols_return argument to a list of atoms,+-- sets the count_return argument to the number of elements+-- in the list, and returns a nonzero status. Otherwise, it+-- sets neither of the return arguments and returns a zero+-- status. To release the list of atoms, use XFree.+--+getWMProtocols :: Display -> Window -> IO [Atom]+getWMProtocols display w = do+ alloca $ \atom_ptr_ptr ->+ alloca $ \count_ptr -> do++ st <- xGetWMProtocols display w atom_ptr_ptr count_ptr+ if st == 0+ then return []+ else do sz <- peek count_ptr+ print sz+ atom_ptr <- peek atom_ptr_ptr+ atoms <- peekArray (fromIntegral sz) atom_ptr+ xFree atom_ptr+ return atoms++foreign import ccall unsafe "HsXlib.h XGetWMProtocols"+ xGetWMProtocols :: Display -> Window -> Ptr (Ptr Atom) -> Ptr CInt -> IO Status+++------------------------------------------------------------------------+-- Creating events++setEventType :: XEventPtr -> EventType -> IO ()+setEventType = #{poke XEvent,type}++-- hacky way to set up an XClientMessageEvent+-- Should have a Storable instance for XEvent/Event?+setClientMessageEvent :: XEventPtr -> Window -> Atom -> CInt -> Atom -> Time -> IO ()+setClientMessageEvent p window message_type format l_0_ l_1_ = do+ #{poke XClientMessageEvent, window} p window+ #{poke XClientMessageEvent, message_type} p message_type+ #{poke XClientMessageEvent, format} p format+ let datap = #{ptr XClientMessageEvent, data} p :: Ptr CLong+ poke datap (fromIntegral l_0_) -- does this work?+ pokeElemOff datap 1 (fromIntegral l_1_)++ return ()+++{-+ typedef struct {+ int type; /* ClientMessage */+ unsigned long serial; /* # of last request processed by server */+ Bool send_event; /* true if this came from a SendEvent request */+ Display *display; /* Display the event was read from */+ Window window;+ Atom message_type;+ int format;+ union {+ char b[20];+ short s[10];+ long l[5];+ } data;+ } XClientMessageEvent;++-}++------------------------------------------------------------------------+-- XErrorEvents+-- +-- I'm too lazy to write the binding+--++foreign import ccall unsafe "XlibExtras.h setErrorHandler"+ xSetErrorHandler :: IO ()++-- | refreshKeyboardMapping. TODO Remove this binding when the fix has been commited to+-- X11+refreshKeyboardMapping :: Display -> (MappingRequest, KeyCode, CInt) -> IO ()+refreshKeyboardMapping (Display d) (request, first_keycode, count)+ = allocaBytes #{size XMappingEvent} $ \p -> do+ #{poke XMappingEvent, display } p d+ #{poke XMappingEvent, request } p request+ #{poke XMappingEvent, first_keycode} p first_keycode+ #{poke XMappingEvent, count } p count+ xRefreshKeyboardMapping p+ return ()++foreign import ccall unsafe "XlibExtras.h XRefreshKeyboardMapping"+ xRefreshKeyboardMapping :: Ptr () -> IO CInt
+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (c) Spencer Janssen++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.+2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.+3. Neither the name of the author nor the names of his contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF+SUCH DAMAGE.
+ README view
@@ -0,0 +1,12 @@+If you are building from a source tarball, you can just use the standard cabal+installation stanza:++$ runghc Setup config+$ runghc Setup build+$ runghc Setup install++However, if you are building from darcs, X11-extras uses autoconf, so you need+to have autoconf installed and run autoconf/autoheader before building:++$ autoconf+$ autoheader
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMainWithHooks defaultUserHooks
+ X11-extras.buildinfo.in view
@@ -0,0 +1,3 @@+cc-options: @X_CFLAGS@+ld-options: @X_LIBS@+@EXTRA_LIBRARIES@
+ X11-extras.cabal view
@@ -0,0 +1,29 @@+name: X11-extras+version: 0.0+license: BSD3+license-file: LICENSE+author: Spencer Janssen+maintainer: sjanssen@cse.unl.edu+copyright: Spencer Janssen 2007+category: Graphics+synopsis: Missing bindings to the X11 graphics library+description: Missing bindings to the X11 graphics library.+ .+ The binding is a direct translation of the C binding; for+ documentation of these calls, refer to "The Xlib Programming+ Manual", available online at <http://tronche.com/gui/x/xlib/>.+exposed-modules: Graphics.X11.Xlib.Extras, Graphics.X11.Xinerama+extensions: ForeignFunctionInterface+build-depends: base, X11>=1.2+ghc-options: -O2 -funbox-strict-fields+extra-libraries: "X11" "Xext"+c-sources: cbits/XUtils.c+install-includes: XlibExtras.h+extra-source-files:+ include/XlibExtras.h+ configure.ac+ configure+ X11-extras.buildinfo.in+ include/config.h.in+include-dirs: include+extra-tmp-files: include/config.h X11-extras.buildinfo config.log config.status autom4te.cache
+ cbits/XUtils.c view
@@ -0,0 +1,31 @@+#include <stdio.h>+#include <X11/X.h>+#include <X11/Xlib.h>+#include <X11/Xproto.h>++int defaultErrorHandler(Display *d, XErrorEvent *ev)+{+ char buffer[1000];+ XGetErrorText(d,ev->error_code,buffer,1000);+ printf("Error: %s\n", buffer);+ return 0;+}++int+xerror(Display *dpy, XErrorEvent *ee) {++ if(ee->error_code == BadWindow+ || (ee->request_code == X_SetInputFocus && ee->error_code == BadMatch)+ || (ee->request_code == X_ConfigureWindow && ee->error_code == BadMatch)+ || (ee->request_code == X_GrabKey && ee->error_code == BadAccess))+ return 0;++ fprintf(stderr, "xmonad: fatal error: request code=%d, error code=%d\n",+ ee->request_code, ee->error_code);++ return defaultErrorHandler(dpy,ee);+}++void setErrorHandler() {+ XSetErrorHandler(xerror);+}
+ configure.ac view
@@ -0,0 +1,24 @@+AC_INIT++AC_CONFIG_HEADERS([include/config.h])++AC_PATH_XTRA++# If there's some oddball X11 include path, we need it to check there for+# Xinerama headers.+if test -n "$x_includes"; then+ CPPFLAGS="$CPPFLAGS -I $x_includes"+fi++AC_CHECK_HEADERS([X11/extensions/Xinerama.h], [have_xinerama=yes])++if test "$have_xinerama" = yes; then+ EXTRA_LIBRARIES="extra-libraries: Xinerama" +else+ EXTRA_LIBRARIES=""+ echo "WARNING: Xinerama headers not found. Building without Xinerama support"+fi+AC_SUBST([EXTRA_LIBRARIES])++AC_CONFIG_FILES([X11-extras.buildinfo])+AC_OUTPUT
+ include/XlibExtras.h view
@@ -0,0 +1,37 @@+/* This file copied from the X11 package */++/* -----------------------------------------------------------------------------+ * Definitions for package `X11' which are visible in Haskell land.+ * ---------------------------------------------------------------------------*+ */++#ifndef XLIBEXTRAS_H+#define XLIBEXTRAS_H+#include <stdlib.h>+/* This doesn't always work, so we play safe below... */+#define XUTIL_DEFINE_FUNCTIONS+#include <X11/X.h>+#include <X11/X.h>+#include <X11/Xlib.h>+#include <X11/Xatom.h>+#include <X11/Xutil.h>+#include <X11/Xproto.h>++/* Xutil.h overrides some functions with macros.+ * In recent versions of X this can be turned off with+ * #define XUTIL_DEFINE_FUNCTIONS+ * before the #include, but this doesn't work with older versions.+ * As a workaround, we undef the macros here. Note that this is only+ * safe for functions with return type int.+ */+#undef XDestroyImage+#undef XGetPixel+#undef XPutPixel+#undef XSubImage+#undef XAddPixel+#define XK_MISCELLANY+#define XK_LATIN1+#include <X11/keysymdef.h>+#endif++void setErrorHandler();