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
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
type_ <- (\hsc_ptr -> peekByteOff hsc_ptr 0) p
serial <- (\hsc_ptr -> peekByteOff hsc_ptr 4) p
send_event <- (\hsc_ptr -> peekByteOff hsc_ptr 8) p
display <- fmap Display ((\hsc_ptr -> peekByteOff hsc_ptr 12) p)
case () of
_ | type_ == configureRequest -> do
parent <- (\hsc_ptr -> peekByteOff hsc_ptr 16) p
window <- (\hsc_ptr -> peekByteOff hsc_ptr 20) p
x <- (\hsc_ptr -> peekByteOff hsc_ptr 24) p
y <- (\hsc_ptr -> peekByteOff hsc_ptr 28) p
width <- (\hsc_ptr -> peekByteOff hsc_ptr 32) p
height <- (\hsc_ptr -> peekByteOff hsc_ptr 36) p
border_width <- (\hsc_ptr -> peekByteOff hsc_ptr 40) p
above <- (\hsc_ptr -> peekByteOff hsc_ptr 44) p
detail <- (\hsc_ptr -> peekByteOff hsc_ptr 48) p
value_mask <- (\hsc_ptr -> peekByteOff hsc_ptr 52) 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
}
| type_ == configureNotify -> do
return (ConfigureEvent type_ serial send_event display)
`ap` (\hsc_ptr -> peekByteOff hsc_ptr 16) p
`ap` (\hsc_ptr -> peekByteOff hsc_ptr 20) p
`ap` (\hsc_ptr -> peekByteOff hsc_ptr 24) p
`ap` (\hsc_ptr -> peekByteOff hsc_ptr 28) p
`ap` (\hsc_ptr -> peekByteOff hsc_ptr 32) p
`ap` (\hsc_ptr -> peekByteOff hsc_ptr 36) p
`ap` (\hsc_ptr -> peekByteOff hsc_ptr 40) p
`ap` (\hsc_ptr -> peekByteOff hsc_ptr 44) p
`ap` (\hsc_ptr -> peekByteOff hsc_ptr 48) p
| type_ == mapRequest -> do
parent <- (\hsc_ptr -> peekByteOff hsc_ptr 16) p
window <- (\hsc_ptr -> peekByteOff hsc_ptr 20) 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
}
| type_ == mapNotify -> do
event <- (\hsc_ptr -> peekByteOff hsc_ptr 16) p
window <- (\hsc_ptr -> peekByteOff hsc_ptr 20) p
override_redirect <- (\hsc_ptr -> peekByteOff hsc_ptr 24) 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
}
| type_ == mappingNotify -> do
window <- (\hsc_ptr -> peekByteOff hsc_ptr 16) p
request <- (\hsc_ptr -> peekByteOff hsc_ptr 20) p
first_keycode <- (\hsc_ptr -> peekByteOff hsc_ptr 24) p
count <- (\hsc_ptr -> peekByteOff hsc_ptr 28) 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
}
| type_ == keyPress || type_ == keyRelease -> do
window <- (\hsc_ptr -> peekByteOff hsc_ptr 16) p
root <- (\hsc_ptr -> peekByteOff hsc_ptr 20) p
subwindow <- (\hsc_ptr -> peekByteOff hsc_ptr 24) p
time <- (\hsc_ptr -> peekByteOff hsc_ptr 28) p
x <- (\hsc_ptr -> peekByteOff hsc_ptr 32) p
y <- (\hsc_ptr -> peekByteOff hsc_ptr 36) p
x_root <- (\hsc_ptr -> peekByteOff hsc_ptr 40) p
y_root <- (\hsc_ptr -> peekByteOff hsc_ptr 44) p
state <- ((\hsc_ptr -> peekByteOff hsc_ptr 48) p) :: IO CUInt
keycode <- (\hsc_ptr -> peekByteOff hsc_ptr 52) p
same_screen <- (\hsc_ptr -> peekByteOff hsc_ptr 56) 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
}
| type_ == buttonPress || type_ == buttonRelease -> do
window <- (\hsc_ptr -> peekByteOff hsc_ptr 16) p
root <- (\hsc_ptr -> peekByteOff hsc_ptr 20) p
subwindow <- (\hsc_ptr -> peekByteOff hsc_ptr 24) p
time <- (\hsc_ptr -> peekByteOff hsc_ptr 28) p
x <- (\hsc_ptr -> peekByteOff hsc_ptr 32) p
y <- (\hsc_ptr -> peekByteOff hsc_ptr 36) p
x_root <- (\hsc_ptr -> peekByteOff hsc_ptr 40) p
y_root <- (\hsc_ptr -> peekByteOff hsc_ptr 44) p
state <- ((\hsc_ptr -> peekByteOff hsc_ptr 48) p) :: IO CUInt
button <- (\hsc_ptr -> peekByteOff hsc_ptr 52) p
same_screen <- (\hsc_ptr -> peekByteOff hsc_ptr 56) 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
}
| type_ == destroyNotify -> do
event <- (\hsc_ptr -> peekByteOff hsc_ptr 16) p
window <- (\hsc_ptr -> peekByteOff hsc_ptr 20) 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
}
| type_ == unmapNotify -> do
event <- (\hsc_ptr -> peekByteOff hsc_ptr 16) p
window <- (\hsc_ptr -> peekByteOff hsc_ptr 20) p
from_configure <- (\hsc_ptr -> peekByteOff hsc_ptr 24) 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
}
| type_ == enterNotify || type_ == leaveNotify -> do
window <- (\hsc_ptr -> peekByteOff hsc_ptr 16) p
root <- (\hsc_ptr -> peekByteOff hsc_ptr 20) p
subwindow <- (\hsc_ptr -> peekByteOff hsc_ptr 24) p
time <- (\hsc_ptr -> peekByteOff hsc_ptr 28) p
x <- (\hsc_ptr -> peekByteOff hsc_ptr 32) p
y <- (\hsc_ptr -> peekByteOff hsc_ptr 36) p
x_root <- (\hsc_ptr -> peekByteOff hsc_ptr 40) p
y_root <- (\hsc_ptr -> peekByteOff hsc_ptr 44) p
mode <- (\hsc_ptr -> peekByteOff hsc_ptr 48) p
detail <- (\hsc_ptr -> peekByteOff hsc_ptr 52) p
same_screen <- (\hsc_ptr -> peekByteOff hsc_ptr 56) p
focus <- (\hsc_ptr -> peekByteOff hsc_ptr 60) p
state <- ((\hsc_ptr -> peekByteOff hsc_ptr 64) 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
}
| otherwise -> do
window <- (\hsc_ptr -> peekByteOff hsc_ptr 16) 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 _ = (28)
alignment _ = alignment (undefined :: CInt)
poke p wc = do
(\hsc_ptr -> pokeByteOff hsc_ptr 0) p $ wc_x wc
(\hsc_ptr -> pokeByteOff hsc_ptr 4) p $ wc_y wc
(\hsc_ptr -> pokeByteOff hsc_ptr 8) p $ wc_width wc
(\hsc_ptr -> pokeByteOff hsc_ptr 12) p $ wc_height wc
(\hsc_ptr -> pokeByteOff hsc_ptr 16) p $ wc_border_width wc
(\hsc_ptr -> pokeByteOff hsc_ptr 20) p $ wc_sibling wc
(\hsc_ptr -> pokeByteOff hsc_ptr 24) p $ wc_stack_mode wc
peek p = return WindowChanges
`ap` ((\hsc_ptr -> peekByteOff hsc_ptr 0) p)
`ap` ((\hsc_ptr -> peekByteOff hsc_ptr 4) p)
`ap` ((\hsc_ptr -> peekByteOff hsc_ptr 8) p)
`ap` ((\hsc_ptr -> peekByteOff hsc_ptr 12) p)
`ap` ((\hsc_ptr -> peekByteOff hsc_ptr 16) p)
`ap` ((\hsc_ptr -> peekByteOff hsc_ptr 20) p)
`ap` ((\hsc_ptr -> peekByteOff hsc_ptr 24) p)
none :: XID
none = 0
anyButton :: Button
anyButton = 0
anyKey :: KeyCode
anyKey = toEnum 0
currentTime :: Time
currentTime = 0
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)
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
alignment _ = alignment (undefined :: CInt)
sizeOf _ = (92)
peek p = return WindowAttributes
`ap` ((\hsc_ptr -> peekByteOff hsc_ptr 0) p)
`ap` ((\hsc_ptr -> peekByteOff hsc_ptr 4) p)
`ap` ((\hsc_ptr -> peekByteOff hsc_ptr 8) p)
`ap` ((\hsc_ptr -> peekByteOff hsc_ptr 12) p)
`ap` ((\hsc_ptr -> peekByteOff hsc_ptr 16) p)
`ap` ((\hsc_ptr -> peekByteOff hsc_ptr 68) p)
`ap` ((\hsc_ptr -> peekByteOff hsc_ptr 84) p)
poke p wa = do
(\hsc_ptr -> pokeByteOff hsc_ptr 0) p $ wa_x wa
(\hsc_ptr -> pokeByteOff hsc_ptr 4) p $ wa_y wa
(\hsc_ptr -> pokeByteOff hsc_ptr 8) p $ wa_width wa
(\hsc_ptr -> pokeByteOff hsc_ptr 12) p $ wa_height wa
(\hsc_ptr -> pokeByteOff hsc_ptr 16) p $ wa_border_width wa
(\hsc_ptr -> pokeByteOff hsc_ptr 68) p $ wa_map_state wa
(\hsc_ptr -> pokeByteOff hsc_ptr 84) 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 $ 2
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
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
setEventType :: XEventPtr -> EventType -> IO ()
setEventType = (\hsc_ptr -> pokeByteOff hsc_ptr 0)
setClientMessageEvent :: XEventPtr -> Window -> Atom -> CInt -> Atom -> Time -> IO ()
setClientMessageEvent p window message_type format l_0_ l_1_ = do
(\hsc_ptr -> pokeByteOff hsc_ptr 16) p window
(\hsc_ptr -> pokeByteOff hsc_ptr 20) p message_type
(\hsc_ptr -> pokeByteOff hsc_ptr 24) p format
let datap = (\hsc_ptr -> hsc_ptr `plusPtr` 28) p :: Ptr CLong
poke datap (fromIntegral l_0_)
pokeElemOff datap 1 (fromIntegral l_1_)
return ()
foreign import ccall unsafe "XlibExtras.h x11_extras_set_error_handler"
xSetErrorHandler :: IO ()
refreshKeyboardMapping :: Event -> IO ()
refreshKeyboardMapping ev@(MappingNotifyEvent {ev_event_display = (Display d)})
= allocaBytes (32) $ \p -> do
(\hsc_ptr -> pokeByteOff hsc_ptr 0) p $ ev_event_type ev
(\hsc_ptr -> pokeByteOff hsc_ptr 4) p $ ev_serial ev
(\hsc_ptr -> pokeByteOff hsc_ptr 8) p $ ev_send_event ev
(\hsc_ptr -> pokeByteOff hsc_ptr 12) p $ d
(\hsc_ptr -> pokeByteOff hsc_ptr 16) p $ ev_window ev
(\hsc_ptr -> pokeByteOff hsc_ptr 20) p $ ev_request ev
(\hsc_ptr -> pokeByteOff hsc_ptr 24) p $ ev_first_keycode ev
(\hsc_ptr -> pokeByteOff hsc_ptr 28) p $ ev_count ev
xRefreshKeyboardMapping p
return ()
refreshKeyboardMapping _ = return ()
foreign import ccall unsafe "XlibExtras.h XRefreshKeyboardMapping"
xRefreshKeyboardMapping :: Ptr () -> IO CInt
foreign import ccall unsafe "XlibExtras.h XChangeProperty"
xChangeProperty :: Display -> Window -> Atom -> Atom -> CInt -> CInt -> Ptr CUChar -> CInt -> IO Status
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 = 0
propModePrepend = 1
propModeAppend = 2