mirror of
https://github.com/xmonad/xmonad.git
synced 2025-05-19 00:20:22 -07:00
254 lines
10 KiB
Haskell
254 lines
10 KiB
Haskell
module Thunk.XlibExtras where
|
|
|
|
import Graphics.X11.Xlib
|
|
import Graphics.X11.Xlib.Types
|
|
import Foreign
|
|
import Foreign.C.Types
|
|
import Control.Monad (ap)
|
|
|
|
#include "XlibExtras.h"
|
|
|
|
data Event
|
|
= AnyEvent
|
|
{ event_type :: EventType
|
|
, serial :: CULong
|
|
, send_event :: Bool
|
|
, event_display :: Display
|
|
, window :: Window
|
|
}
|
|
| ConfigureRequestEvent
|
|
{ event_type :: EventType
|
|
, serial :: CULong
|
|
, send_event :: Bool
|
|
, event_display :: Display
|
|
, parent :: Window
|
|
, window :: Window
|
|
, x :: Int
|
|
, y :: Int
|
|
, width :: Int
|
|
, height :: Int
|
|
, border_width :: Int
|
|
, above :: Window
|
|
, detail :: Int
|
|
, value_mask :: CULong
|
|
}
|
|
| MapRequestEvent
|
|
{ event_type :: EventType
|
|
, serial :: CULong
|
|
, send_event :: Bool
|
|
, event_display :: Display
|
|
, parent :: Window
|
|
, window :: Window
|
|
}
|
|
| KeyEvent
|
|
{ event_type :: EventType
|
|
, serial :: CULong
|
|
, send_event :: Bool
|
|
, event_display :: Display
|
|
, window :: Window
|
|
, root :: Window
|
|
, subwindow :: Window
|
|
, time :: Time
|
|
, x :: Int
|
|
, y :: Int
|
|
, x_root :: Int
|
|
, y_root :: Int
|
|
, state :: KeyMask
|
|
, keycode :: KeyCode
|
|
, same_screen :: Bool
|
|
}
|
|
| DestroyWindowEvent
|
|
{ event_type :: EventType
|
|
, serial :: CULong
|
|
, send_event :: Bool
|
|
, event_display :: Display
|
|
, event :: Window
|
|
, window :: Window
|
|
}
|
|
| UnmapEvent
|
|
{ event_type :: EventType
|
|
, serial :: CULong
|
|
, send_event :: Bool
|
|
, event_display :: Display
|
|
, event :: Window
|
|
, window :: Window
|
|
, fromConfigure :: Bool
|
|
}
|
|
deriving Show
|
|
|
|
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
|
|
{ event_type = type_
|
|
, serial = serial_
|
|
, send_event = send_event_
|
|
, event_display = display_
|
|
, parent = parent_
|
|
, window = window_
|
|
, x = x_
|
|
, y = y_
|
|
, width = width_
|
|
, height = height_
|
|
, border_width = border_width_
|
|
, above = above_
|
|
, detail = detail_
|
|
, value_mask = value_mask_
|
|
}
|
|
|
|
-------------------
|
|
-- MapRequestEvent:
|
|
-------------------
|
|
| type_ == mapRequest -> do
|
|
parent_ <- #{peek XMapRequestEvent, parent} p
|
|
window_ <- #{peek XMapRequestEvent, window} p
|
|
return $ MapRequestEvent
|
|
{ event_type = type_
|
|
, serial = serial_
|
|
, send_event = send_event_
|
|
, event_display = display_
|
|
, parent = parent_
|
|
, window = window_
|
|
}
|
|
|
|
------------
|
|
-- 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
|
|
keycode_ <- #{peek XKeyEvent, keycode } p
|
|
same_screen_ <- #{peek XKeyEvent, same_screen} p
|
|
return $ KeyEvent
|
|
{ event_type = type_
|
|
, serial = serial_
|
|
, send_event = send_event_
|
|
, event_display = display_
|
|
, window = window_
|
|
, root = root_
|
|
, subwindow = subwindow_
|
|
, time = time_
|
|
, x = x_
|
|
, y = y_
|
|
, x_root = x_root_
|
|
, y_root = y_root_
|
|
, state = state_
|
|
, keycode = keycode_
|
|
, same_screen = same_screen_
|
|
}
|
|
|
|
----------------------
|
|
-- DestroyWindowEvent:
|
|
----------------------
|
|
| type_ == destroyNotify -> do
|
|
event_ <- #{peek XDestroyWindowEvent, event } p
|
|
window_ <- #{peek XDestroyWindowEvent, window} p
|
|
return $ DestroyWindowEvent
|
|
{ event_type = type_
|
|
, serial = serial_
|
|
, send_event = send_event_
|
|
, event_display = display_
|
|
, event = event_
|
|
, window = window_
|
|
}
|
|
|
|
|
|
--------------------
|
|
-- UnmapNotifyEvent:
|
|
--------------------
|
|
| type_ == unmapNotify -> do
|
|
event_ <- #{peek XUnmapEvent, event } p
|
|
window_ <- #{peek XUnmapEvent, window } p
|
|
fromConfigure_ <- #{peek XUnmapEvent, from_configure} p
|
|
return $ UnmapEvent
|
|
{ event_type = type_
|
|
, serial = serial_
|
|
, send_event = send_event_
|
|
, event_display = display_
|
|
, event = event_
|
|
, window = window_
|
|
, fromConfigure = fromConfigure_
|
|
}
|
|
|
|
-- We don't handle this event specifically, so return the generic
|
|
-- AnyEvent.
|
|
| otherwise -> do
|
|
window_ <- #{peek XAnyEvent, window} p
|
|
return $ AnyEvent
|
|
{ event_type = type_
|
|
, serial = serial_
|
|
, send_event = send_event_
|
|
, event_display = display_
|
|
, window = window_
|
|
}
|
|
|
|
data WindowChanges = WindowChanges
|
|
{ wcX :: Int
|
|
, wcY :: Int
|
|
, wcWidth :: Int
|
|
, wcHeight:: Int
|
|
, wcBorderWidth :: Int
|
|
, wcSibling :: Window
|
|
, wcStackMode :: Int
|
|
}
|
|
|
|
instance Storable WindowChanges where
|
|
sizeOf _ = #{size XWindowChanges}
|
|
|
|
-- I really hope this is right:
|
|
alignment _ = alignment (undefined :: Int)
|
|
|
|
poke p wc = do
|
|
#{poke XWindowChanges, x } p $ wcX wc
|
|
#{poke XWindowChanges, y } p $ wcY wc
|
|
#{poke XWindowChanges, width } p $ wcWidth wc
|
|
#{poke XWindowChanges, height } p $ wcHeight wc
|
|
#{poke XWindowChanges, border_width} p $ wcBorderWidth wc
|
|
#{poke XWindowChanges, sibling } p $ wcSibling wc
|
|
#{poke XWindowChanges, stack_mode } p $ wcStackMode 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)
|
|
|
|
foreign import ccall unsafe "XlibExtras.h XConfigureWindow"
|
|
xConfigureWindow :: Display -> Window -> CULong -> Ptr WindowChanges -> IO Int
|
|
|
|
configureWindow :: Display -> Window -> CULong -> WindowChanges -> IO ()
|
|
configureWindow d w m c = do
|
|
with c (xConfigureWindow d w m)
|
|
return ()
|