X11-extras-0.2: Graphics/X11/Xlib/Extras.hsc
-----------------------------------------------------------------------------
-- |
-- 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 Foreign.C.String
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
}
| ConfigureEvent
{ ev_event_type :: !EventType
, ev_serial :: !CULong
, ev_send_event :: !Bool
, ev_event_display :: Display
, ev_event :: !Window
, ev_window :: !Window
, ev_x :: !CInt
, ev_y :: !CInt
, ev_width :: !CInt
, ev_height :: !CInt
, ev_border_width :: !CInt
, ev_above :: !Window
, ev_override_redirect :: !Bool
}
| 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
}
------------------
-- ConfigureEvent:
------------------
| type_ == configureNotify -> do
return (ConfigureEvent type_ serial send_event display)
`ap` #{peek XConfigureEvent, event } p
`ap` #{peek XConfigureEvent, window } p
`ap` #{peek XConfigureEvent, x } p
`ap` #{peek XConfigureEvent, y } p
`ap` #{peek XConfigureEvent, width } p
`ap` #{peek XConfigureEvent, height } p
`ap` #{peek XConfigureEvent, border_width } p
`ap` #{peek XConfigureEvent, above } p
`ap` #{peek XConfigureEvent, override_redirect } p
-------------------
-- 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}
anyKey :: KeyCode
anyKey = toEnum #{const AnyKey}
currentTime :: Time
currentTime = #{const CurrentTime}
--
-- 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
foreign import ccall unsafe "XlibExtras.h XFetchName"
xFetchName :: Display -> Window -> Ptr CString -> IO Status
fetchName :: Display -> Window -> IO (Maybe String)
fetchName d w = alloca $ \p -> do
xFetchName d w p
cstr <- peek p
if cstr == nullPtr
then return Nothing
else do
str <- peekCString cstr
xFree cstr
return $ Just str
foreign import ccall unsafe "XlibExtras.h XGetTransientForHint"
xGetTransientForHint :: Display -> Window -> Ptr Window -> IO Status
getTransientForHint :: Display -> Window -> IO (Maybe Window)
getTransientForHint d w = alloca $ \wp -> do
status <- xGetTransientForHint d w wp
if status == 0
then return Nothing
else Just `liftM` peek wp
------------------------------------------------------------------------
-- 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 x11_extras_set_error_handler"
xSetErrorHandler :: IO ()
-- | refreshKeyboardMapping. TODO Remove this binding when the fix has been commited to
-- X11
refreshKeyboardMapping :: Event -> IO ()
refreshKeyboardMapping ev@(MappingNotifyEvent {ev_event_display = (Display d)})
= allocaBytes #{size XMappingEvent} $ \p -> do
#{poke XMappingEvent, type } p $ ev_event_type ev
#{poke XMappingEvent, serial } p $ ev_serial ev
#{poke XMappingEvent, send_event } p $ ev_send_event ev
#{poke XMappingEvent, display } p $ d
#{poke XMappingEvent, window } p $ ev_window ev
#{poke XMappingEvent, request } p $ ev_request ev
#{poke XMappingEvent, first_keycode } p $ ev_first_keycode ev
#{poke XMappingEvent, count } p $ ev_count ev
xRefreshKeyboardMapping p
return ()
refreshKeyboardMapping _ = return ()
foreign import ccall unsafe "XlibExtras.h XRefreshKeyboardMapping"
xRefreshKeyboardMapping :: Ptr () -> IO CInt
-- Properties
foreign import ccall unsafe "XlibExtras.h XChangeProperty"
xChangeProperty :: Display -> Window -> Atom -> Atom -> CInt -> CInt -> Ptr CUChar -> CInt -> IO Status
-- this assumes bytes are 8 bits. I hope X isn't more portable than that :(
changeProperty8 :: Display -> Window -> Atom -> Atom -> CInt -> [Char] -> IO ()
changeProperty8 dpy w prop typ mode dat =
withArrayLen (map (fromIntegral . fromEnum) dat) $ \ len ptr -> do
xChangeProperty dpy w prop typ 8 mode ptr (fromIntegral len)
return ()
propModeReplace, propModePrepend, propModeAppend :: CInt
propModeReplace = #{const PropModeReplace}
propModePrepend = #{const PropModePrepend}
propModeAppend = #{const PropModeAppend}