diff --git a/Graphics/X11/Xinerama.hsc b/Graphics/X11/Xinerama.hsc new file mode 100644 --- /dev/null +++ b/Graphics/X11/Xinerama.hsc @@ -0,0 +1,129 @@ +-- | Interface to Xinerama API +module Graphics.X11.Xinerama + (XineramaScreenInfo(..), + xineramaIsActive, + xineramaQueryExtension, + xineramaQueryVersion, + xineramaQueryScreens, + getScreenInfo) where + +#include + +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 + +#include + +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 diff --git a/Graphics/X11/Xlib/Extras.hsc b/Graphics/X11/Xlib/Extras.hsc new file mode 100644 --- /dev/null +++ b/Graphics/X11/Xlib/Extras.hsc @@ -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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -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 diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMainWithHooks defaultUserHooks diff --git a/X11-extras.buildinfo.in b/X11-extras.buildinfo.in new file mode 100644 --- /dev/null +++ b/X11-extras.buildinfo.in @@ -0,0 +1,3 @@ +cc-options: @X_CFLAGS@ +ld-options: @X_LIBS@ +@EXTRA_LIBRARIES@ diff --git a/X11-extras.cabal b/X11-extras.cabal new file mode 100644 --- /dev/null +++ b/X11-extras.cabal @@ -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 . +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 diff --git a/cbits/XUtils.c b/cbits/XUtils.c new file mode 100644 --- /dev/null +++ b/cbits/XUtils.c @@ -0,0 +1,31 @@ +#include +#include +#include +#include + +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); +} diff --git a/configure.ac b/configure.ac new file mode 100644 --- /dev/null +++ b/configure.ac @@ -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 diff --git a/include/XlibExtras.h b/include/XlibExtras.h new file mode 100644 --- /dev/null +++ b/include/XlibExtras.h @@ -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 +/* This doesn't always work, so we play safe below... */ +#define XUTIL_DEFINE_FUNCTIONS +#include +#include +#include +#include +#include +#include + +/* 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 +#endif + +void setErrorHandler();