1{-# LANGUAGE DeriveDataTypeable #-} 2----------------------------------------------------------------------------- 3-- | 4-- Module : Graphics.X11.Xlib.Extras 5-- Copyright : 2007 (c) Spencer Janssen 6-- License : BSD3-style (see LICENSE) 7-- Stability : experimental 8-- 9----------------------------------------------------------------------------- 10-- 11-- missing functionality from the X11 library 12-- 13 14module Graphics.X11.Xlib.Extras ( 15 module Graphics.X11.Xlib.Extras, 16 module Graphics.X11.Xlib.Internal 17 ) where 18 19import Data.Maybe 20import Data.Typeable ( Typeable ) 21import Graphics.X11.Xrandr 22import Graphics.X11.XScreenSaver 23import Graphics.X11.Xlib 24import Graphics.X11.Xlib.Internal 25import Graphics.X11.Xlib.Types 26import Foreign (Storable, Ptr, peek, poke, peekElemOff, pokeElemOff, peekByteOff, pokeByteOff, peekArray, throwIfNull, nullPtr, sizeOf, alignment, alloca, with, throwIf, Word8, Word16, #{type unsigned long}, Int32, plusPtr, castPtr, withArrayLen, setBit, testBit, allocaBytes, FunPtr) 27import Foreign.C.Types 28import Foreign.C.String 29import Control.Monad 30 31import System.IO.Unsafe 32 33#include "XlibExtras.h" 34 35data Event 36 = AnyEvent 37 { ev_event_type :: !EventType 38 , ev_serial :: !CULong 39 , ev_send_event :: !Bool 40 , ev_event_display :: Display 41 , ev_window :: !Window 42 } 43 | ConfigureRequestEvent 44 { ev_event_type :: !EventType 45 , ev_serial :: !CULong 46 , ev_send_event :: !Bool 47 , ev_event_display :: Display 48 , ev_parent :: !Window 49 , ev_window :: !Window 50 , ev_x :: !CInt 51 , ev_y :: !CInt 52 , ev_width :: !CInt 53 , ev_height :: !CInt 54 , ev_border_width :: !CInt 55 , ev_above :: !Window 56 , ev_detail :: !NotifyDetail 57 , ev_value_mask :: !CULong 58 } 59 | ConfigureEvent 60 { ev_event_type :: !EventType 61 , ev_serial :: !CULong 62 , ev_send_event :: !Bool 63 , ev_event_display :: Display 64 , ev_event :: !Window 65 , ev_window :: !Window 66 , ev_x :: !CInt 67 , ev_y :: !CInt 68 , ev_width :: !CInt 69 , ev_height :: !CInt 70 , ev_border_width :: !CInt 71 , ev_above :: !Window 72 , ev_override_redirect :: !Bool 73 } 74 | MapRequestEvent 75 { ev_event_type :: !EventType 76 , ev_serial :: !CULong 77 , ev_send_event :: !Bool 78 , ev_event_display :: Display 79 , ev_parent :: !Window 80 , ev_window :: !Window 81 } 82 | KeyEvent 83 { ev_event_type :: !EventType 84 , ev_serial :: !CULong 85 , ev_send_event :: !Bool 86 , ev_event_display :: Display 87 , ev_window :: !Window 88 , ev_root :: !Window 89 , ev_subwindow :: !Window 90 , ev_time :: !Time 91 , ev_x :: !CInt 92 , ev_y :: !CInt 93 , ev_x_root :: !CInt 94 , ev_y_root :: !CInt 95 , ev_state :: !KeyMask 96 , ev_keycode :: !KeyCode 97 , ev_same_screen :: !Bool 98 } 99 | ButtonEvent 100 { ev_event_type :: !EventType 101 , ev_serial :: !CULong 102 , ev_send_event :: !Bool 103 , ev_event_display :: Display 104 , ev_window :: !Window 105 , ev_root :: !Window 106 , ev_subwindow :: !Window 107 , ev_time :: !Time 108 , ev_x :: !CInt 109 , ev_y :: !CInt 110 , ev_x_root :: !CInt 111 , ev_y_root :: !CInt 112 , ev_state :: !KeyMask 113 , ev_button :: !Button 114 , ev_same_screen :: !Bool 115 } 116 | MotionEvent 117 { ev_event_type :: !EventType 118 , ev_serial :: !CULong 119 , ev_send_event :: !Bool 120 , ev_event_display :: Display 121 , ev_x :: !CInt 122 , ev_y :: !CInt 123 , ev_window :: !Window 124 } 125 | DestroyWindowEvent 126 { ev_event_type :: !EventType 127 , ev_serial :: !CULong 128 , ev_send_event :: !Bool 129 , ev_event_display :: Display 130 , ev_event :: !Window 131 , ev_window :: !Window 132 } 133 | UnmapEvent 134 { ev_event_type :: !EventType 135 , ev_serial :: !CULong 136 , ev_send_event :: !Bool 137 , ev_event_display :: Display 138 , ev_event :: !Window 139 , ev_window :: !Window 140 , ev_from_configure :: !Bool 141 } 142 | MapNotifyEvent 143 { ev_event_type :: !EventType 144 , ev_serial :: !CULong 145 , ev_send_event :: !Bool 146 , ev_event_display :: Display 147 , ev_event :: !Window 148 , ev_window :: !Window 149 , ev_override_redirect :: !Bool 150 } 151 | MappingNotifyEvent 152 { ev_event_type :: !EventType 153 , ev_serial :: !CULong 154 , ev_send_event :: !Bool 155 , ev_event_display :: Display 156 , ev_window :: !Window 157 , ev_request :: !MappingRequest 158 , ev_first_keycode :: !KeyCode 159 , ev_count :: !CInt 160 } 161 | CrossingEvent 162 { ev_event_type :: !EventType 163 , ev_serial :: !CULong 164 , ev_send_event :: !Bool 165 , ev_event_display :: Display 166 , ev_window :: !Window 167 , ev_root :: !Window 168 , ev_subwindow :: !Window 169 , ev_time :: !Time 170 , ev_x :: !CInt 171 , ev_y :: !CInt 172 , ev_x_root :: !CInt 173 , ev_y_root :: !CInt 174 , ev_mode :: !NotifyMode 175 , ev_detail :: !NotifyDetail 176 , ev_same_screen :: !Bool 177 , ev_focus :: !Bool 178 , ev_state :: !Modifier 179 } 180 | SelectionRequest 181 { ev_event_type :: !EventType 182 , ev_serial :: !CULong 183 , ev_send_event :: !Bool 184 , ev_event_display :: Display 185 , ev_owner :: !Window 186 , ev_requestor :: !Window 187 , ev_selection :: !Atom 188 , ev_target :: !Atom 189 , ev_property :: !Atom 190 , ev_time :: !Time 191 } 192 | SelectionClear 193 { ev_event_type :: !EventType 194 , ev_serial :: !CULong 195 , ev_send_event :: !Bool 196 , ev_event_display :: Display 197 , ev_window :: !Window 198 , ev_selection :: !Atom 199 , ev_time :: !Time 200 } 201 | PropertyEvent 202 { ev_event_type :: !EventType 203 , ev_serial :: !CULong 204 , ev_send_event :: !Bool 205 , ev_event_display :: Display 206 , ev_window :: !Window 207 , ev_atom :: !Atom 208 , ev_time :: !Time 209 , ev_propstate :: !CInt 210 } 211 | ExposeEvent 212 { ev_event_type :: !EventType 213 , ev_serial :: !CULong 214 , ev_send_event :: !Bool 215 , ev_event_display :: Display 216 , ev_window :: !Window 217 , ev_x :: !CInt 218 , ev_y :: !CInt 219 , ev_width :: !CInt 220 , ev_height :: !CInt 221 , ev_count :: !CInt 222 } 223 | ClientMessageEvent 224 { ev_event_type :: !EventType 225 , ev_serial :: !CULong 226 , ev_send_event :: !Bool 227 , ev_event_display :: Display 228 , ev_window :: !Window 229 , ev_message_type :: !Atom 230 , ev_data :: ![CInt] 231 } 232 | RRScreenChangeNotifyEvent 233 { ev_event_type :: !EventType 234 , ev_serial :: !CULong 235 , ev_send_event :: !Bool 236 , ev_event_display :: Display 237 , ev_window :: !Window 238 , ev_root :: !Window 239 , ev_timestamp :: !Time 240 , ev_config_timestamp :: !Time 241 , ev_size_index :: !SizeID 242 , ev_subpixel_order :: !SubpixelOrder 243 , ev_rotation :: !Rotation 244 , ev_width :: !CInt 245 , ev_height :: !CInt 246 , ev_mwidth :: !CInt 247 , ev_mheight :: !CInt 248 } 249 | RRNotifyEvent 250 { ev_event_type :: !EventType 251 , ev_serial :: !CULong 252 , ev_send_event :: !Bool 253 , ev_event_display :: Display 254 , ev_window :: !Window 255 , ev_subtype :: !CInt 256 } 257 | RRCrtcChangeNotifyEvent 258 { ev_event_type :: !EventType 259 , ev_serial :: !CULong 260 , ev_send_event :: !Bool 261 , ev_event_display :: Display 262 , ev_window :: !Window 263 , ev_subtype :: !CInt 264 , ev_crtc :: !RRCrtc 265 , ev_rr_mode :: !RRMode 266 , ev_rotation :: !Rotation 267 , ev_x :: !CInt 268 , ev_y :: !CInt 269 , ev_rr_width :: !CUInt 270 , ev_rr_height :: !CUInt 271 } 272 | RROutputChangeNotifyEvent 273 { ev_event_type :: !EventType 274 , ev_serial :: !CULong 275 , ev_send_event :: !Bool 276 , ev_event_display :: Display 277 , ev_window :: !Window 278 , ev_subtype :: !CInt 279 , ev_output :: !RROutput 280 , ev_crtc :: !RRCrtc 281 , ev_rr_mode :: !RRMode 282 , ev_rotation :: !Rotation 283 , ev_connection :: !Connection 284 , ev_subpixel_order :: !SubpixelOrder 285 } 286 | RROutputPropertyNotifyEvent 287 { ev_event_type :: !EventType 288 , ev_serial :: !CULong 289 , ev_send_event :: !Bool 290 , ev_event_display :: Display 291 , ev_window :: !Window 292 , ev_subtype :: !CInt 293 , ev_output :: !RROutput 294 , ev_property :: !Atom 295 , ev_timestamp :: !Time 296 , ev_rr_state :: !CInt 297 } 298 | ScreenSaverNotifyEvent 299 { ev_event_type :: !EventType 300 , ev_serial :: !CULong 301 , ev_send_event :: !Bool 302 , ev_event_display :: Display 303 , ev_window :: !Window 304 , ev_root :: !Window 305 , ev_ss_state :: !XScreenSaverState 306 , ev_ss_kind :: !XScreenSaverKind 307 , ev_forced :: !Bool 308 , ev_time :: !Time 309 } 310 deriving ( Show, Typeable ) 311 312eventTable :: [(EventType, String)] 313eventTable = 314 [ (keyPress , "KeyPress") 315 , (keyRelease , "KeyRelease") 316 , (buttonPress , "ButtonPress") 317 , (buttonRelease , "ButtonRelease") 318 , (motionNotify , "MotionNotify") 319 , (enterNotify , "EnterNotify") 320 , (leaveNotify , "LeaveNotify") 321 , (focusIn , "FocusIn") 322 , (focusOut , "FocusOut") 323 , (keymapNotify , "KeymapNotify") 324 , (expose , "Expose") 325 , (graphicsExpose , "GraphicsExpose") 326 , (noExpose , "NoExpose") 327 , (visibilityNotify , "VisibilityNotify") 328 , (createNotify , "CreateNotify") 329 , (destroyNotify , "DestroyNotify") 330 , (unmapNotify , "UnmapNotify") 331 , (mapNotify , "MapNotify") 332 , (mapRequest , "MapRequest") 333 , (reparentNotify , "ReparentNotify") 334 , (configureNotify , "ConfigureNotify") 335 , (configureRequest , "ConfigureRequest") 336 , (gravityNotify , "GravityNotify") 337 , (resizeRequest , "ResizeRequest") 338 , (circulateNotify , "CirculateNotify") 339 , (circulateRequest , "CirculateRequest") 340 , (propertyNotify , "PropertyNotify") 341 , (selectionClear , "SelectionClear") 342 , (selectionRequest , "SelectionRequest") 343 , (selectionNotify , "SelectionNotify") 344 , (colormapNotify , "ColormapNotify") 345 , (clientMessage , "ClientMessage") 346 , (mappingNotify , "MappingNotify") 347 , (lASTEvent , "LASTEvent") 348 , (screenSaverNotify , "ScreenSaverNotify") 349 ] 350 351eventName :: Event -> String 352eventName e = maybe ("unknown " ++ show x) id $ lookup x eventTable 353 where x = fromIntegral $ ev_event_type e 354 355getEvent :: XEventPtr -> IO Event 356getEvent p = do 357 -- All events share this layout and naming convention, there is also a 358 -- common Window field, but the names for this field vary. 359 type_ <- #{peek XAnyEvent, type} p 360 serial <- #{peek XAnyEvent, serial} p 361 send_event <- #{peek XAnyEvent, send_event} p 362 display <- fmap Display (#{peek XAnyEvent, display} p) 363 rrData <- xrrQueryExtension display 364 let rrHasExtension = isJust rrData 365 let rrEventBase = fromIntegral $ fst $ fromMaybe (0, 0) rrData 366 case () of 367 368 ------------------------- 369 -- ConfigureRequestEvent: 370 ------------------------- 371 _ | type_ == configureRequest -> do 372 parent <- #{peek XConfigureRequestEvent, parent } p 373 window <- #{peek XConfigureRequestEvent, window } p 374 x <- #{peek XConfigureRequestEvent, x } p 375 y <- #{peek XConfigureRequestEvent, y } p 376 width <- #{peek XConfigureRequestEvent, width } p 377 height <- #{peek XConfigureRequestEvent, height } p 378 border_width <- #{peek XConfigureRequestEvent, border_width} p 379 above <- #{peek XConfigureRequestEvent, above } p 380 detail <- #{peek XConfigureRequestEvent, detail } p 381 value_mask <- #{peek XConfigureRequestEvent, value_mask } p 382 return $ ConfigureRequestEvent 383 { ev_event_type = type_ 384 , ev_serial = serial 385 , ev_send_event = send_event 386 , ev_event_display = display 387 , ev_parent = parent 388 , ev_window = window 389 , ev_x = x 390 , ev_y = y 391 , ev_width = width 392 , ev_height = height 393 , ev_border_width = border_width 394 , ev_above = above 395 , ev_detail = detail 396 , ev_value_mask = value_mask 397 } 398 399 ------------------ 400 -- ConfigureEvent: 401 ------------------ 402 | type_ == configureNotify -> do 403 return (ConfigureEvent type_ serial send_event display) 404 `ap` #{peek XConfigureEvent, event } p 405 `ap` #{peek XConfigureEvent, window } p 406 `ap` #{peek XConfigureEvent, x } p 407 `ap` #{peek XConfigureEvent, y } p 408 `ap` #{peek XConfigureEvent, width } p 409 `ap` #{peek XConfigureEvent, height } p 410 `ap` #{peek XConfigureEvent, border_width } p 411 `ap` #{peek XConfigureEvent, above } p 412 `ap` #{peek XConfigureEvent, override_redirect } p 413 414 ------------------- 415 -- MapRequestEvent: 416 ------------------- 417 | type_ == mapRequest -> do 418 parent <- #{peek XMapRequestEvent, parent} p 419 window <- #{peek XMapRequestEvent, window} p 420 return $ MapRequestEvent 421 { ev_event_type = type_ 422 , ev_serial = serial 423 , ev_send_event = send_event 424 , ev_event_display = display 425 , ev_parent = parent 426 , ev_window = window 427 } 428 429 ------------------- 430 -- MapNotifyEvent 431 ------------------- 432 | type_ == mapNotify -> do 433 event <- #{peek XMapEvent, event} p 434 window <- #{peek XMapEvent, window} p 435 override_redirect <- #{peek XMapEvent, override_redirect} p 436 return $ MapNotifyEvent 437 { ev_event_type = type_ 438 , ev_serial = serial 439 , ev_send_event = send_event 440 , ev_event_display = display 441 , ev_event = event 442 , ev_window = window 443 , ev_override_redirect = override_redirect 444 } 445 446 ------------------- 447 -- MappingNotifyEvent 448 ------------------- 449 | type_ == mappingNotify -> do 450 window <- #{peek XMappingEvent,window} p 451 request <- #{peek XMappingEvent,request} p 452 first_keycode <- #{peek XMappingEvent,first_keycode} p 453 count <- #{peek XMappingEvent,count} p 454 455 return $ MappingNotifyEvent 456 { ev_event_type = type_ 457 , ev_serial = serial 458 , ev_send_event = send_event 459 , ev_event_display = display 460 , ev_window = window 461 , ev_request = request 462 , ev_first_keycode = first_keycode 463 , ev_count = count 464 } 465 466 ------------ 467 -- KeyEvent: 468 ------------ 469 | type_ == keyPress || type_ == keyRelease -> do 470 window <- #{peek XKeyEvent, window } p 471 root <- #{peek XKeyEvent, root } p 472 subwindow <- #{peek XKeyEvent, subwindow } p 473 time <- #{peek XKeyEvent, time } p 474 x <- #{peek XKeyEvent, x } p 475 y <- #{peek XKeyEvent, y } p 476 x_root <- #{peek XKeyEvent, x_root } p 477 y_root <- #{peek XKeyEvent, y_root } p 478 state <- (#{peek XKeyEvent, state } p) :: IO CUInt 479 keycode <- (#{peek XKeyEvent, keycode } p) :: IO CUInt 480 same_screen <- #{peek XKeyEvent, same_screen} p 481 return $ KeyEvent 482 { ev_event_type = type_ 483 , ev_serial = serial 484 , ev_send_event = send_event 485 , ev_event_display = display 486 , ev_window = window 487 , ev_root = root 488 , ev_subwindow = subwindow 489 , ev_time = time 490 , ev_x = x 491 , ev_y = y 492 , ev_x_root = x_root 493 , ev_y_root = y_root 494 , ev_state = fromIntegral state 495 , ev_keycode = fromIntegral keycode 496 , ev_same_screen = same_screen 497 } 498 499 --------------- 500 -- ButtonEvent: 501 --------------- 502 | type_ == buttonPress || type_ == buttonRelease -> do 503 504 window <- #{peek XButtonEvent, window } p 505 root <- #{peek XButtonEvent, root } p 506 subwindow <- #{peek XButtonEvent, subwindow } p 507 time <- #{peek XButtonEvent, time } p 508 x <- #{peek XButtonEvent, x } p 509 y <- #{peek XButtonEvent, y } p 510 x_root <- #{peek XButtonEvent, x_root } p 511 y_root <- #{peek XButtonEvent, y_root } p 512 state <- (#{peek XButtonEvent, state } p) :: IO CUInt 513 button <- #{peek XButtonEvent, button } p 514 same_screen <- #{peek XButtonEvent, same_screen} p 515 516 return $ ButtonEvent 517 { ev_event_type = type_ 518 , ev_serial = serial 519 , ev_send_event = send_event 520 , ev_event_display = display 521 , ev_window = window 522 , ev_root = root 523 , ev_subwindow = subwindow 524 , ev_time = time 525 , ev_x = x 526 , ev_y = y 527 , ev_x_root = x_root 528 , ev_y_root = y_root 529 , ev_state = fromIntegral state 530 , ev_button = button 531 , ev_same_screen = same_screen 532 } 533 534 --------------- 535 -- MotionEvent: 536 --------------- 537 | type_ == motionNotify -> do 538 window <- #{peek XMotionEvent, window} p 539 x <- #{peek XMotionEvent, x } p 540 y <- #{peek XMotionEvent, y } p 541 return $ MotionEvent 542 { ev_event_type = type_ 543 , ev_serial = serial 544 , ev_send_event = send_event 545 , ev_event_display = display 546 , ev_x = x 547 , ev_y = y 548 , ev_window = window 549 } 550 551 552 ---------------------- 553 -- DestroyWindowEvent: 554 ---------------------- 555 | type_ == destroyNotify -> do 556 event <- #{peek XDestroyWindowEvent, event } p 557 window <- #{peek XDestroyWindowEvent, window} p 558 return $ DestroyWindowEvent 559 { ev_event_type = type_ 560 , ev_serial = serial 561 , ev_send_event = send_event 562 , ev_event_display = display 563 , ev_event = event 564 , ev_window = window 565 } 566 567 568 -------------------- 569 -- UnmapNotifyEvent: 570 -------------------- 571 | type_ == unmapNotify -> do 572 event <- #{peek XUnmapEvent, event } p 573 window <- #{peek XUnmapEvent, window } p 574 from_configure <- #{peek XUnmapEvent, from_configure} p 575 return $ UnmapEvent 576 { ev_event_type = type_ 577 , ev_serial = serial 578 , ev_send_event = send_event 579 , ev_event_display = display 580 , ev_event = event 581 , ev_window = window 582 , ev_from_configure = from_configure 583 } 584 585 -------------------- 586 -- CrossingEvent 587 -------------------- 588 | type_ == enterNotify || type_ == leaveNotify -> do 589 window <- #{peek XCrossingEvent, window } p 590 root <- #{peek XCrossingEvent, root } p 591 subwindow <- #{peek XCrossingEvent, subwindow } p 592 time <- #{peek XCrossingEvent, time } p 593 x <- #{peek XCrossingEvent, x } p 594 y <- #{peek XCrossingEvent, y } p 595 x_root <- #{peek XCrossingEvent, x_root } p 596 y_root <- #{peek XCrossingEvent, y_root } p 597 mode <- #{peek XCrossingEvent, mode } p 598 detail <- #{peek XCrossingEvent, detail } p 599 same_screen <- #{peek XCrossingEvent, same_screen } p 600 focus <- #{peek XCrossingEvent, focus } p 601 state <- (#{peek XCrossingEvent, state } p) :: IO CUInt 602 603 return $ CrossingEvent 604 { ev_event_type = type_ 605 , ev_serial = serial 606 , ev_send_event = send_event 607 , ev_event_display = display 608 , ev_window = window 609 , ev_root = root 610 , ev_subwindow = subwindow 611 , ev_time = time 612 , ev_x = x 613 , ev_y = y 614 , ev_x_root = x_root 615 , ev_y_root = y_root 616 , ev_mode = mode 617 , ev_detail = detail 618 , ev_same_screen = same_screen 619 , ev_focus = focus 620 , ev_state = fromIntegral state 621 } 622 623 ------------------------- 624 -- SelectionRequestEvent: 625 ------------------------- 626 | type_ == selectionRequest -> do 627 owner <- #{peek XSelectionRequestEvent, owner } p 628 requestor <- #{peek XSelectionRequestEvent, requestor } p 629 selection <- #{peek XSelectionRequestEvent, selection } p 630 target <- #{peek XSelectionRequestEvent, target } p 631 property <- #{peek XSelectionRequestEvent, property } p 632 time <- #{peek XSelectionRequestEvent, time } p 633 return $ SelectionRequest 634 { ev_event_type = type_ 635 , ev_serial = serial 636 , ev_send_event = send_event 637 , ev_event_display = display 638 , ev_owner = owner 639 , ev_requestor = requestor 640 , ev_selection = selection 641 , ev_target = target 642 , ev_property = property 643 , ev_time = time 644 } 645 646 ------------------------- 647 -- SelectionClearEvent: 648 ------------------------- 649 | type_ == selectionClear -> do 650 window <- #{peek XSelectionClearEvent, window } p 651 atom <- #{peek XSelectionClearEvent, selection } p 652 time <- #{peek XSelectionClearEvent, time } p 653 return $ SelectionClear 654 { ev_event_type = type_ 655 , ev_serial = serial 656 , ev_send_event = send_event 657 , ev_event_display = display 658 , ev_window = window 659 , ev_selection = atom 660 , ev_time = time 661 } 662 ------------------------- 663 -- PropertyEvent 664 ------------------------- 665 | type_ == propertyNotify -> do 666 window <- #{peek XPropertyEvent, window } p 667 atom <- #{peek XPropertyEvent, atom } p 668 time <- #{peek XPropertyEvent, time } p 669 state <- #{peek XPropertyEvent, state } p 670 return $ PropertyEvent 671 { ev_event_type = type_ 672 , ev_serial = serial 673 , ev_send_event = send_event 674 , ev_event_display = display 675 , ev_window = window 676 , ev_atom = atom 677 , ev_time = time 678 , ev_propstate = state 679 } 680 681 ------------------------- 682 -- ExposeEvent 683 ------------------------- 684 | type_ == expose -> do 685 window <- #{peek XExposeEvent, window } p 686 x <- #{peek XExposeEvent, x } p 687 y <- #{peek XExposeEvent, y } p 688 width <- #{peek XExposeEvent, width } p 689 height <- #{peek XExposeEvent, height } p 690 count <- #{peek XExposeEvent, count } p 691 return $ ExposeEvent 692 { ev_event_type = type_ 693 , ev_serial = serial 694 , ev_send_event = send_event 695 , ev_event_display = display 696 , ev_window = window 697 , ev_x = x 698 , ev_y = y 699 , ev_width = width 700 , ev_height = height 701 , ev_count = count 702 } 703 704 ------------------------- 705 -- ClientMessageEvent 706 ------------------------- 707 | type_ == clientMessage -> do 708 window <- #{peek XClientMessageEvent, window } p 709 message_type <- #{peek XClientMessageEvent, message_type } p 710 format <- #{peek XClientMessageEvent, format } p 711 let datPtr = #{ptr XClientMessageEvent, data } p 712 dat <- case (format::CInt) of 713 8 -> do a <- peekArray 20 datPtr 714 return $ map fromIntegral (a::[Word8]) 715 16 -> do a <- peekArray 10 datPtr 716 return $ map fromIntegral (a::[Word16]) 717 32 -> do a <- peekArray 5 datPtr 718 return $ map fromIntegral (a::[CLong]) 719 _ -> error "X11.Extras.clientMessage: illegal value" 720 return $ ClientMessageEvent 721 { ev_event_type = type_ 722 , ev_serial = serial 723 , ev_send_event = send_event 724 , ev_event_display = display 725 , ev_window = window 726 , ev_message_type = message_type 727 , ev_data = dat 728 } 729 730 ------------------------- 731 -- RRScreenChangeNotify 732 ------------------------- 733 | rrHasExtension && 734 type_ == rrEventBase + rrScreenChangeNotify -> do 735 window <- #{peek XRRScreenChangeNotifyEvent, window } p 736 root <- #{peek XRRScreenChangeNotifyEvent, root } p 737 timestamp <- #{peek XRRScreenChangeNotifyEvent, timestamp } p 738 config_timestamp <- #{peek XRRScreenChangeNotifyEvent, config_timestamp } p 739 size_index <- #{peek XRRScreenChangeNotifyEvent, config_timestamp } p 740 subpixel_order <- #{peek XRRScreenChangeNotifyEvent, subpixel_order } p 741 rotation <- #{peek XRRScreenChangeNotifyEvent, rotation } p 742 width <- #{peek XRRScreenChangeNotifyEvent, width } p 743 height <- #{peek XRRScreenChangeNotifyEvent, height } p 744 mwidth <- #{peek XRRScreenChangeNotifyEvent, mwidth } p 745 mheight <- #{peek XRRScreenChangeNotifyEvent, mheight } p 746 return $ RRScreenChangeNotifyEvent 747 { ev_event_type = type_ 748 , ev_serial = serial 749 , ev_send_event = send_event 750 , ev_event_display = display 751 , ev_window = window 752 , ev_root = root 753 , ev_timestamp = timestamp 754 , ev_config_timestamp = config_timestamp 755 , ev_size_index = size_index 756 , ev_subpixel_order = subpixel_order 757 , ev_rotation = rotation 758 , ev_width = width 759 , ev_height = height 760 , ev_mwidth = mwidth 761 , ev_mheight = mheight 762 } 763 764 ------------------------- 765 -- RRNotify 766 ------------------------- 767 | rrHasExtension && 768 type_ == rrEventBase + rrNotify -> do 769 window <- #{peek XRRNotifyEvent, window } p 770 subtype <- #{peek XRRNotifyEvent, subtype } p 771 let subtype_ = fromIntegral subtype_ 772 case () of 773 _ | subtype_ == rrNotifyCrtcChange -> do 774 crtc <- #{peek XRRCrtcChangeNotifyEvent, crtc } p 775 mode <- #{peek XRRCrtcChangeNotifyEvent, mode } p 776 rotation <- #{peek XRRCrtcChangeNotifyEvent, rotation } p 777 x <- #{peek XRRCrtcChangeNotifyEvent, x } p 778 y <- #{peek XRRCrtcChangeNotifyEvent, y } p 779 width <- #{peek XRRCrtcChangeNotifyEvent, width } p 780 height <- #{peek XRRCrtcChangeNotifyEvent, height } p 781 return $ RRCrtcChangeNotifyEvent 782 { ev_event_type = type_ 783 , ev_serial = serial 784 , ev_send_event = send_event 785 , ev_event_display = display 786 , ev_window = window 787 , ev_subtype = subtype 788 , ev_crtc = crtc 789 , ev_rr_mode = mode 790 , ev_rotation = rotation 791 , ev_x = x 792 , ev_y = y 793 , ev_rr_width = width 794 , ev_rr_height = height 795 } 796 797 | subtype_ == rrNotifyOutputChange -> do 798 output <- #{peek XRROutputChangeNotifyEvent, output } p 799 crtc <- #{peek XRROutputChangeNotifyEvent, crtc } p 800 mode <- #{peek XRROutputChangeNotifyEvent, mode } p 801 rotation <- #{peek XRROutputChangeNotifyEvent, rotation } p 802 connection <- #{peek XRROutputChangeNotifyEvent, connection } p 803 subpixel_order <- #{peek XRROutputChangeNotifyEvent, subpixel_order } p 804 return $ RROutputChangeNotifyEvent 805 { ev_event_type = type_ 806 , ev_serial = serial 807 , ev_send_event = send_event 808 , ev_event_display = display 809 , ev_window = window 810 , ev_subtype = subtype 811 , ev_output = output 812 , ev_crtc = crtc 813 , ev_rr_mode = mode 814 , ev_rotation = rotation 815 , ev_connection = connection 816 , ev_subpixel_order = subpixel_order 817 } 818 819 | subtype_ == rrNotifyOutputProperty -> do 820 output <- #{peek XRROutputPropertyNotifyEvent, output } p 821 property <- #{peek XRROutputPropertyNotifyEvent, property } p 822 timestamp <- #{peek XRROutputPropertyNotifyEvent, timestamp } p 823 state <- #{peek XRROutputPropertyNotifyEvent, state } p 824 return $ RROutputPropertyNotifyEvent 825 { ev_event_type = type_ 826 , ev_serial = serial 827 , ev_send_event = send_event 828 , ev_event_display = display 829 , ev_window = window 830 , ev_subtype = subtype 831 , ev_output = output 832 , ev_property = property 833 , ev_timestamp = timestamp 834 , ev_rr_state = state 835 } 836 837 -- We don't handle this event specifically, so return the generic 838 -- RRNotifyEvent. 839 | otherwise -> do 840 return $ RRNotifyEvent 841 { ev_event_type = type_ 842 , ev_serial = serial 843 , ev_send_event = send_event 844 , ev_event_display = display 845 , ev_window = window 846 , ev_subtype = subtype 847 } 848 849 ----------------- 850 -- ScreenSaverNotifyEvent: 851 ----------------- 852 | type_ == screenSaverNotify -> do 853 return (ScreenSaverNotifyEvent type_ serial send_event display) 854 `ap` (#{peek XScreenSaverNotifyEvent, window } p ) 855 `ap` (#{peek XScreenSaverNotifyEvent, root } p ) 856 `ap` (#{peek XScreenSaverNotifyEvent, state } p ) 857 `ap` (#{peek XScreenSaverNotifyEvent, kind } p ) 858 `ap` (#{peek XScreenSaverNotifyEvent, forced } p ) 859 `ap` (#{peek XScreenSaverNotifyEvent, time } p ) 860 861 -- We don't handle this event specifically, so return the generic 862 -- AnyEvent. 863 | otherwise -> do 864 window <- #{peek XAnyEvent, window} p 865 return $ AnyEvent 866 { ev_event_type = type_ 867 , ev_serial = serial 868 , ev_send_event = send_event 869 , ev_event_display = display 870 , ev_window = window 871 } 872 873data WindowChanges = WindowChanges 874 { wc_x :: CInt 875 , wc_y :: CInt 876 , wc_width :: CInt 877 , wc_height:: CInt 878 , wc_border_width :: CInt 879 , wc_sibling :: Window 880 , wc_stack_mode :: CInt 881 } 882 883instance Storable WindowChanges where 884 sizeOf _ = #{size XWindowChanges} 885 886 -- I really hope this is right: 887 alignment _ = alignment (undefined :: CInt) 888 889 poke p wc = do 890 #{poke XWindowChanges, x } p $ wc_x wc 891 #{poke XWindowChanges, y } p $ wc_y wc 892 #{poke XWindowChanges, width } p $ wc_width wc 893 #{poke XWindowChanges, height } p $ wc_height wc 894 #{poke XWindowChanges, border_width} p $ wc_border_width wc 895 #{poke XWindowChanges, sibling } p $ wc_sibling wc 896 #{poke XWindowChanges, stack_mode } p $ wc_stack_mode wc 897 898 peek p = return WindowChanges 899 `ap` (#{peek XWindowChanges, x} p) 900 `ap` (#{peek XWindowChanges, y} p) 901 `ap` (#{peek XWindowChanges, width} p) 902 `ap` (#{peek XWindowChanges, height} p) 903 `ap` (#{peek XWindowChanges, border_width} p) 904 `ap` (#{peek XWindowChanges, sibling} p) 905 `ap` (#{peek XWindowChanges, stack_mode} p) 906 907-- 908-- Some extra constants 909-- 910 911none :: XID 912none = #{const None} 913 914anyButton :: Button 915anyButton = #{const AnyButton} 916 917anyKey :: KeyCode 918anyKey = toEnum #{const AnyKey} 919 920currentTime :: Time 921currentTime = #{const CurrentTime} 922 923-- 924-- The use of Int rather than CInt isn't 64 bit clean. 925-- 926 927foreign import ccall unsafe "XlibExtras.h XConfigureWindow" 928 xConfigureWindow :: Display -> Window -> CULong -> Ptr WindowChanges -> IO CInt 929 930foreign import ccall unsafe "XlibExtras.h XKillClient" 931 killClient :: Display -> Window -> IO CInt 932 933configureWindow :: Display -> Window -> CULong -> WindowChanges -> IO () 934configureWindow d w m c = do 935 _ <- with c (xConfigureWindow d w m) 936 return () 937 938foreign import ccall unsafe "XlibExtras.h XQueryTree" 939 xQueryTree :: Display -> Window -> Ptr Window -> Ptr Window -> Ptr (Ptr Window) -> Ptr CInt -> IO Status 940 941queryTree :: Display -> Window -> IO (Window, Window, [Window]) 942queryTree d w = 943 alloca $ \root_return -> 944 alloca $ \parent_return -> 945 alloca $ \children_return -> 946 alloca $ \nchildren_return -> do 947 _ <- throwIfZero "queryTree" $ xQueryTree d w root_return parent_return children_return nchildren_return 948 p <- peek children_return 949 n <- fmap fromIntegral $ peek nchildren_return 950 ws <- peekArray n p 951 _ <- xFree p 952 liftM3 (,,) (peek root_return) (peek parent_return) (return ws) 953 954-- TODO: this data type is incomplete wrt. the C struct 955data WindowAttributes = WindowAttributes 956 { wa_x, wa_y, wa_width, wa_height, wa_border_width :: CInt 957 , wa_colormap :: Colormap 958 , wa_map_installed :: Bool 959 , wa_map_state :: CInt 960 , wa_override_redirect :: Bool 961 } 962 963-- 964-- possible map_states' 965-- 966waIsUnmapped, waIsUnviewable, waIsViewable :: CInt 967waIsUnmapped = fromIntegral ( #{const IsUnmapped} :: CInt ) -- 0 968waIsUnviewable = fromIntegral ( #{const IsUnviewable} :: CInt ) -- 1 969waIsViewable = fromIntegral ( #{const IsViewable} :: CInt ) -- 2 970 971instance Storable WindowAttributes where 972 -- this might be incorrect 973 alignment _ = alignment (undefined :: CInt) 974 sizeOf _ = #{size XWindowAttributes} 975 peek p = return WindowAttributes 976 `ap` (#{peek XWindowAttributes, x } p) 977 `ap` (#{peek XWindowAttributes, y } p) 978 `ap` (#{peek XWindowAttributes, width } p) 979 `ap` (#{peek XWindowAttributes, height } p) 980 `ap` (#{peek XWindowAttributes, border_width } p) 981 `ap` (#{peek XWindowAttributes, colormap } p) 982 `ap` (#{peek XWindowAttributes, map_installed } p) 983 `ap` (#{peek XWindowAttributes, map_state } p) 984 `ap` (#{peek XWindowAttributes, override_redirect} p) 985 poke p wa = do 986 #{poke XWindowAttributes, x } p $ wa_x wa 987 #{poke XWindowAttributes, y } p $ wa_y wa 988 #{poke XWindowAttributes, width } p $ wa_width wa 989 #{poke XWindowAttributes, height } p $ wa_height wa 990 #{poke XWindowAttributes, border_width } p $ wa_border_width wa 991 #{poke XWindowAttributes, colormap } p $ wa_colormap wa 992 #{poke XWindowAttributes, map_installed } p $ wa_map_installed wa 993 #{poke XWindowAttributes, map_state } p $ wa_map_state wa 994 #{poke XWindowAttributes, override_redirect} p $ wa_override_redirect wa 995 996foreign import ccall unsafe "XlibExtras.h XGetWindowAttributes" 997 xGetWindowAttributes :: Display -> Window -> Ptr (WindowAttributes) -> IO Status 998 999getWindowAttributes :: Display -> Window -> IO WindowAttributes 1000getWindowAttributes d w = alloca $ \p -> do 1001 _ <- throwIfZero "getWindowAttributes" $ xGetWindowAttributes d w p 1002 peek p 1003 1004-- | interface to the X11 library function @XChangeWindowAttributes()@. 1005foreign import ccall unsafe "XlibExtras.h XChangeWindowAttributes" 1006 changeWindowAttributes :: Display -> Window -> AttributeMask -> Ptr SetWindowAttributes -> IO () 1007 1008-- | Run an action with the server 1009withServer :: Display -> IO () -> IO () 1010withServer dpy f = do 1011 grabServer dpy 1012 f 1013 ungrabServer dpy 1014 1015data TextProperty = TextProperty { 1016 tp_value :: CString, 1017 tp_encoding :: Atom, 1018 tp_format :: CInt, 1019 tp_nitems :: #{type unsigned long} 1020 } 1021 1022instance Storable TextProperty where 1023 sizeOf _ = #{size XTextProperty} 1024 alignment _ = alignment (undefined :: #{type unsigned long}) 1025 peek p = TextProperty `fmap` #{peek XTextProperty, value } p 1026 `ap` #{peek XTextProperty, encoding} p 1027 `ap` #{peek XTextProperty, format } p 1028 `ap` #{peek XTextProperty, nitems } p 1029 poke p (TextProperty val enc fmt nitems) = do 1030 #{poke XTextProperty, value } p val 1031 #{poke XTextProperty, encoding} p enc 1032 #{poke XTextProperty, format } p fmt 1033 #{poke XTextProperty, nitems } p nitems 1034 1035foreign import ccall unsafe "XlibExtras.h XGetTextProperty" 1036 xGetTextProperty :: Display -> Window -> Ptr TextProperty -> Atom -> IO Status 1037 1038getTextProperty :: Display -> Window -> Atom -> IO TextProperty 1039getTextProperty d w a = 1040 alloca $ \textp -> do 1041 _ <- throwIf (0==) (const "getTextProperty") $ xGetTextProperty d w textp a 1042 peek textp 1043 1044foreign import ccall unsafe "XlibExtras.h XwcTextPropertyToTextList" 1045 xwcTextPropertyToTextList :: Display -> Ptr TextProperty -> Ptr (Ptr CWString) -> Ptr CInt -> IO CInt 1046 1047wcTextPropertyToTextList :: Display -> TextProperty -> IO [String] 1048wcTextPropertyToTextList d prop = 1049 alloca $ \listp -> 1050 alloca $ \countp -> 1051 with prop $ \propp -> do 1052 _ <- throwIf (success>) (const "wcTextPropertyToTextList") $ 1053 xwcTextPropertyToTextList d propp listp countp 1054 count <- peek countp 1055 list <- peek listp 1056 texts <- flip mapM [0..fromIntegral count - 1] $ \i -> 1057 peekElemOff list i >>= peekCWString 1058 wcFreeStringList list 1059 return texts 1060 1061foreign import ccall unsafe "XlibExtras.h XwcFreeStringList" 1062 wcFreeStringList :: Ptr CWString -> IO () 1063 1064newtype FontSet = FontSet (Ptr FontSet) 1065 deriving (Eq, Ord, Show) 1066 1067foreign import ccall unsafe "XlibExtras.h XCreateFontSet" 1068 xCreateFontSet :: Display -> CString -> Ptr (Ptr CString) -> Ptr CInt -> Ptr CString -> IO (Ptr FontSet) 1069 1070createFontSet :: Display -> String -> IO ([String], String, FontSet) 1071createFontSet d fn = 1072 withCString fn $ \fontp -> 1073 alloca $ \listp -> 1074 alloca $ \countp -> 1075 alloca $ \defp -> do 1076 fs <- throwIfNull "createFontSet" $ 1077 xCreateFontSet d fontp listp countp defp 1078 count <- peek countp 1079 list <- peek listp 1080 missing <- flip mapM [0..fromIntegral count - 1] $ \i -> 1081 peekElemOff list i >>= peekCString 1082 def <- peek defp >>= peekCString 1083 freeStringList list 1084 return (missing, def, FontSet fs) 1085 1086foreign import ccall unsafe "XlibExtras.h XFreeStringList" 1087 freeStringList :: Ptr CString -> IO () 1088 1089foreign import ccall unsafe "XlibExtras.h XFreeFontSet" 1090 freeFontSet :: Display -> FontSet -> IO () 1091 1092foreign import ccall unsafe "XlibExtras.h XwcTextExtents" 1093 xwcTextExtents :: FontSet -> CWString -> CInt -> Ptr Rectangle -> Ptr Rectangle -> IO CInt 1094 1095wcTextExtents :: FontSet -> String -> (Rectangle, Rectangle) 1096wcTextExtents fs text = unsafePerformIO $ 1097 withCWStringLen text $ \(textp, len) -> 1098 alloca $ \inkp -> 1099 alloca $ \logicalp -> do 1100 _ <- xwcTextExtents fs textp (fromIntegral len) inkp logicalp 1101 (,) `fmap` peek inkp `ap` peek logicalp 1102 1103foreign import ccall unsafe "XlibExtras.h XwcDrawString" 1104 xwcDrawString :: Display -> Drawable -> FontSet -> GC -> Position -> Position -> CWString -> CInt -> IO () 1105 1106wcDrawString :: Display -> Drawable -> FontSet -> GC -> Position -> Position -> String -> IO () 1107wcDrawString d w fs gc x y = 1108 flip withCWStringLen $ \(s, len) -> 1109 xwcDrawString d w fs gc x y s (fromIntegral len) 1110 1111foreign import ccall unsafe "XlibExtras.h XwcDrawImageString" 1112 xwcDrawImageString :: Display -> Drawable -> FontSet -> GC -> Position -> Position -> CWString -> CInt -> IO () 1113 1114wcDrawImageString :: Display -> Drawable -> FontSet -> GC -> Position -> Position -> String -> IO () 1115wcDrawImageString d w fs gc x y = 1116 flip withCWStringLen $ \(s, len) -> 1117 xwcDrawImageString d w fs gc x y s (fromIntegral len) 1118 1119foreign import ccall unsafe "XlibExtras.h XwcTextEscapement" 1120 xwcTextEscapement :: FontSet -> CWString -> CInt -> IO Int32 1121 1122wcTextEscapement :: FontSet -> String -> Int32 1123wcTextEscapement font_set string = unsafePerformIO $ 1124 withCWStringLen string $ \ (c_string, len) -> 1125 xwcTextEscapement font_set c_string (fromIntegral len) 1126 1127foreign import ccall unsafe "XlibExtras.h XFetchName" 1128 xFetchName :: Display -> Window -> Ptr CString -> IO Status 1129 1130fetchName :: Display -> Window -> IO (Maybe String) 1131fetchName d w = alloca $ \p -> do 1132 _ <- xFetchName d w p 1133 cstr <- peek p 1134 if cstr == nullPtr 1135 then return Nothing 1136 else do 1137 str <- peekCString cstr 1138 _ <- xFree cstr 1139 return $ Just str 1140 1141foreign import ccall unsafe "XlibExtras.h XGetTransientForHint" 1142 xGetTransientForHint :: Display -> Window -> Ptr Window -> IO Status 1143 1144getTransientForHint :: Display -> Window -> IO (Maybe Window) 1145getTransientForHint d w = alloca $ \wp -> do 1146 status <- xGetTransientForHint d w wp 1147 if status == 0 1148 then return Nothing 1149 else Just `liftM` peek wp 1150 1151------------------------------------------------------------------------ 1152-- setWMProtocols :: Display -> Window -> [Atom] -> IO () 1153 1154{- 1155setWMProtocols :: Display -> Window -> [Atom] -> IO () 1156setWMProtocols display w protocols = 1157 withArray protocols $ \ protocol_array -> 1158 xSetWMProtocols display w protocol_array (length protocols) 1159foreign import ccall unsafe "HsXlib.h XSetWMProtocols" 1160 xSetWMProtocols :: Display -> Window -> Ptr Atom -> CInt -> IO () 1161-} 1162 1163-- | The XGetWMProtocols function returns the list of atoms 1164-- stored in the WM_PROTOCOLS property on the specified window. 1165-- These atoms describe window manager protocols in 1166-- which the owner of this window is willing to participate. 1167-- If the property exists, is of type ATOM, is of format 32, 1168-- and the atom WM_PROTOCOLS can be interned, XGetWMProtocols 1169-- sets the protocols_return argument to a list of atoms, 1170-- sets the count_return argument to the number of elements 1171-- in the list, and returns a nonzero status. Otherwise, it 1172-- sets neither of the return arguments and returns a zero 1173-- status. To release the list of atoms, use XFree. 1174-- 1175getWMProtocols :: Display -> Window -> IO [Atom] 1176getWMProtocols display w = do 1177 alloca $ \atom_ptr_ptr -> 1178 alloca $ \count_ptr -> do 1179 1180 st <- xGetWMProtocols display w atom_ptr_ptr count_ptr 1181 if st == 0 1182 then return [] 1183 else do sz <- peek count_ptr 1184 atom_ptr <- peek atom_ptr_ptr 1185 atoms <- peekArray (fromIntegral sz) atom_ptr 1186 _ <- xFree atom_ptr 1187 return atoms 1188 1189foreign import ccall unsafe "HsXlib.h XGetWMProtocols" 1190 xGetWMProtocols :: Display -> Window -> Ptr (Ptr Atom) -> Ptr CInt -> IO Status 1191 1192 1193------------------------------------------------------------------------ 1194-- Creating events 1195 1196setEventType :: XEventPtr -> EventType -> IO () 1197setEventType = #{poke XEvent,type} 1198 1199{- 1200typedef struct { 1201 int type; /* SelectionNotify */ 1202 unsigned long serial; /* # of last request processed by server */ 1203 Bool send_event; /* true if this came from a SendEvent request */ 1204 Display *display; /* Display the event was read from */ 1205 Window requestor; 1206 Atom selection; 1207 Atom target; 1208 Atom property; /* atom or None */ 1209 Time time; 1210} XSelectionEvent; 1211-} 1212 1213setSelectionNotify :: XEventPtr -> Window -> Atom -> Atom -> Atom -> Time -> IO () 1214setSelectionNotify p requestor selection target property time = do 1215 setEventType p selectionNotify 1216 #{poke XSelectionEvent, requestor} p requestor 1217 #{poke XSelectionEvent, selection} p selection 1218 #{poke XSelectionEvent, target} p target 1219 #{poke XSelectionEvent, property} p property 1220 #{poke XSelectionEvent, time} p time 1221 1222-- hacky way to set up an XClientMessageEvent 1223-- Should have a Storable instance for XEvent/Event? 1224setClientMessageEvent :: XEventPtr -> Window -> Atom -> CInt -> Atom -> Time -> IO () 1225setClientMessageEvent p window message_type format l_0_ l_1_ = do 1226 #{poke XClientMessageEvent, window} p window 1227 #{poke XClientMessageEvent, message_type} p message_type 1228 #{poke XClientMessageEvent, format} p format 1229 let datap = #{ptr XClientMessageEvent, data} p :: Ptr CLong 1230 poke datap (fromIntegral l_0_) -- does this work? 1231 pokeElemOff datap 1 (fromIntegral l_1_) 1232 1233 return () 1234 1235setConfigureEvent :: XEventPtr -> Window -> Window -> CInt -> CInt -> CInt -> CInt -> CInt -> Window -> Bool -> IO () 1236setConfigureEvent p ev win x y w h bw abv org = do 1237 #{poke XConfigureEvent, event } p ev 1238 #{poke XConfigureEvent, window } p win 1239 #{poke XConfigureEvent, x } p x 1240 #{poke XConfigureEvent, y } p y 1241 #{poke XConfigureEvent, width } p w 1242 #{poke XConfigureEvent, height } p h 1243 #{poke XConfigureEvent, border_width } p bw 1244 #{poke XConfigureEvent, above } p abv 1245 #{poke XConfigureEvent, override_redirect} p (if org then 1 else 0 :: CInt) 1246 1247setKeyEvent :: XEventPtr -> Window -> Window -> Window -> KeyMask -> KeyCode -> Bool -> IO () 1248setKeyEvent p win root subwin state keycode sameScreen = do 1249 #{poke XKeyEvent, window } p win 1250 #{poke XKeyEvent, root } p root 1251 #{poke XKeyEvent, subwindow } p subwin 1252 #{poke XKeyEvent, time } p currentTime 1253 #{poke XKeyEvent, x } p (1 :: CInt) 1254 #{poke XKeyEvent, y } p (1 :: CInt) 1255 #{poke XKeyEvent, x_root } p (1 :: CInt) 1256 #{poke XKeyEvent, y_root } p (1 :: CInt) 1257 #{poke XKeyEvent, state } p state 1258 #{poke XKeyEvent, keycode } p keycode 1259 #{poke XKeyEvent, same_screen } p sameScreen 1260 return () 1261 1262{- 1263 typedef struct { 1264 int type; /* ClientMessage */ 1265 unsigned long serial; /* # of last request processed by server */ 1266 Bool send_event; /* true if this came from a SendEvent request */ 1267 Display *display; /* Display the event was read from */ 1268 Window window; 1269 Atom message_type; 1270 int format; 1271 union { 1272 char b[20]; 1273 short s[10]; 1274 long l[5]; 1275 } data; 1276 } XClientMessageEvent; 1277 1278-} 1279 1280------------------------------------------------------------------------ 1281-- XErrorEvents 1282-- 1283-- I'm too lazy to write the binding 1284-- 1285 1286foreign import ccall unsafe "XlibExtras.h x11_extras_set_error_handler" 1287 xSetErrorHandler :: IO () 1288 1289-- | refreshKeyboardMapping. TODO Remove this binding when the fix has been commited to 1290-- X11 1291refreshKeyboardMapping :: Event -> IO () 1292refreshKeyboardMapping ev@(MappingNotifyEvent {ev_event_display = (Display d)}) 1293 = allocaBytes #{size XMappingEvent} $ \p -> do 1294 #{poke XMappingEvent, type } p $ ev_event_type ev 1295 #{poke XMappingEvent, serial } p $ ev_serial ev 1296 #{poke XMappingEvent, send_event } p $ ev_send_event ev 1297 #{poke XMappingEvent, display } p $ d 1298 #{poke XMappingEvent, window } p $ ev_window ev 1299 #{poke XMappingEvent, request } p $ ev_request ev 1300 #{poke XMappingEvent, first_keycode } p $ ev_first_keycode ev 1301 #{poke XMappingEvent, count } p $ ev_count ev 1302 _ <- xRefreshKeyboardMapping p 1303 return () 1304refreshKeyboardMapping _ = return () 1305 1306foreign import ccall unsafe "XlibExtras.h XRefreshKeyboardMapping" 1307 xRefreshKeyboardMapping :: Ptr () -> IO CInt 1308 1309-- Properties 1310 1311anyPropertyType :: Atom 1312anyPropertyType = #{const AnyPropertyType} 1313 1314foreign import ccall unsafe "XlibExtras.h XChangeProperty" 1315 xChangeProperty :: Display -> Window -> Atom -> Atom -> CInt -> CInt -> Ptr CUChar -> CInt -> IO Status 1316 1317foreign import ccall unsafe "XlibExtras.h XDeleteProperty" 1318 xDeleteProperty :: Display -> Window -> Atom -> IO Status 1319 1320foreign import ccall unsafe "XlibExtras.h XGetWindowProperty" 1321 xGetWindowProperty :: Display -> Window -> Atom -> CLong -> CLong -> Bool -> Atom -> Ptr Atom -> Ptr CInt -> Ptr CULong -> Ptr CULong -> Ptr (Ptr CUChar) -> IO Status 1322 1323rawGetWindowProperty :: Storable a => Int -> Display -> Atom -> Window -> IO (Maybe [a]) 1324rawGetWindowProperty bits d atom w = 1325 alloca $ \actual_type_return -> 1326 alloca $ \actual_format_return -> 1327 alloca $ \nitems_return -> 1328 alloca $ \bytes_after_return -> 1329 alloca $ \prop_return -> do 1330 ret <- xGetWindowProperty d w atom 0 0xFFFFFFFF False anyPropertyType 1331 actual_type_return 1332 actual_format_return 1333 nitems_return 1334 bytes_after_return 1335 prop_return 1336 1337 if ret /= 0 1338 then return Nothing 1339 else do 1340 prop_ptr <- peek prop_return 1341 actual_format <- fromIntegral `fmap` peek actual_format_return 1342 nitems <- fromIntegral `fmap` peek nitems_return 1343 getprop prop_ptr nitems actual_format 1344 where 1345 getprop prop_ptr nitems actual_format 1346 | actual_format == 0 = return Nothing -- Property not found 1347 | actual_format /= bits = xFree prop_ptr >> return Nothing 1348 | otherwise = do 1349 retval <- peekArray nitems (castPtr prop_ptr) 1350 _ <- xFree prop_ptr 1351 return $ Just retval 1352 1353getWindowProperty8 :: Display -> Atom -> Window -> IO (Maybe [CChar]) 1354getWindowProperty8 = rawGetWindowProperty 8 1355 1356getWindowProperty16 :: Display -> Atom -> Window -> IO (Maybe [CShort]) 1357getWindowProperty16 = rawGetWindowProperty 16 1358 1359getWindowProperty32 :: Display -> Atom -> Window -> IO (Maybe [CLong]) 1360getWindowProperty32 = rawGetWindowProperty 32 1361 1362-- this assumes bytes are 8 bits. I hope X isn't more portable than that :( 1363 1364changeProperty8 :: Display -> Window -> Atom -> Atom -> CInt -> [CChar] -> IO () 1365changeProperty8 dpy w prop typ mode dat = 1366 withArrayLen dat $ \ len ptr -> do 1367 _ <- xChangeProperty dpy w prop typ 8 mode (castPtr ptr) (fromIntegral len) 1368 return () 1369 1370changeProperty16 :: Display -> Window -> Atom -> Atom -> CInt -> [CShort] -> IO () 1371changeProperty16 dpy w prop typ mode dat = 1372 withArrayLen dat $ \ len ptr -> do 1373 _ <- xChangeProperty dpy w prop typ 16 mode (castPtr ptr) (fromIntegral len) 1374 return () 1375 1376changeProperty32 :: Display -> Window -> Atom -> Atom -> CInt -> [CLong] -> IO () 1377changeProperty32 dpy w prop typ mode dat = 1378 withArrayLen dat $ \ len ptr -> do 1379 _ <- xChangeProperty dpy w prop typ 32 mode (castPtr ptr) (fromIntegral len) 1380 return () 1381 1382propModeReplace, propModePrepend, propModeAppend :: CInt 1383propModeReplace = #{const PropModeReplace} 1384propModePrepend = #{const PropModePrepend} 1385propModeAppend = #{const PropModeAppend} 1386 1387deleteProperty :: Display -> Window -> Atom -> IO () 1388deleteProperty dpy w prop = do 1389 _ <- xDeleteProperty dpy w prop 1390 return () 1391 1392-- Windows 1393 1394foreign import ccall unsafe "XlibExtras.h XUnmapWindow" 1395 xUnmapWindow :: Display -> Window -> IO CInt 1396 1397unmapWindow :: Display -> Window -> IO () 1398unmapWindow d w = xUnmapWindow d w >> return () 1399 1400------------------------------------------------------------------------ 1401-- Size hints 1402 1403data SizeHints = SizeHints 1404 { sh_min_size :: Maybe (Dimension, Dimension) 1405 , sh_max_size :: Maybe (Dimension, Dimension) 1406 , sh_resize_inc :: Maybe (Dimension, Dimension) 1407 , sh_aspect :: Maybe ((Dimension, Dimension), (Dimension, Dimension)) 1408 , sh_base_size :: Maybe (Dimension, Dimension) 1409 , sh_win_gravity :: Maybe (BitGravity) 1410 } 1411 1412pMinSizeBit, pMaxSizeBit, pResizeIncBit, pAspectBit, pBaseSizeBit, pWinGravityBit :: Int 1413pMinSizeBit = 4 1414pMaxSizeBit = 5 1415pResizeIncBit = 6 1416pAspectBit = 7 1417pBaseSizeBit = 8 1418pWinGravityBit = 9 1419 1420instance Storable SizeHints where 1421 alignment _ = alignment (undefined :: CInt) 1422 sizeOf _ = #{size XSizeHints} 1423 1424 poke p sh = do 1425 let whenSet f x = maybe (return ()) x (f sh) 1426 let pokeFlag b = do flag <- #{peek XSizeHints, flags} p :: IO CLong 1427 #{poke XSizeHints, flags} p (setBit flag b) 1428 #{poke XSizeHints, flags} p (0 :: CLong) 1429 whenSet sh_min_size $ \(w, h) -> do 1430 pokeFlag pMinSizeBit 1431 #{poke XSizeHints, min_width } p w 1432 #{poke XSizeHints, min_height } p h 1433 whenSet sh_max_size $ \(w, h) -> do 1434 pokeFlag pMaxSizeBit 1435 #{poke XSizeHints, max_width } p w 1436 #{poke XSizeHints, max_height } p h 1437 whenSet sh_resize_inc $ \(w, h) -> do 1438 pokeFlag pResizeIncBit 1439 #{poke XSizeHints, width_inc } p w 1440 #{poke XSizeHints, height_inc } p h 1441 whenSet sh_aspect $ \((minx, miny), (maxx, maxy)) -> do 1442 pokeFlag pAspectBit 1443 #{poke XSizeHints, min_aspect.x} p minx 1444 #{poke XSizeHints, min_aspect.y} p miny 1445 #{poke XSizeHints, max_aspect.x} p maxx 1446 #{poke XSizeHints, max_aspect.y} p maxy 1447 whenSet sh_base_size $ \(w, h) -> do 1448 pokeFlag pBaseSizeBit 1449 #{poke XSizeHints, base_width } p w 1450 #{poke XSizeHints, base_height } p h 1451 whenSet sh_win_gravity $ \g -> do 1452 pokeFlag pWinGravityBit 1453 #{poke XSizeHints, win_gravity } p g 1454 1455 peek p = do 1456 flags <- #{peek XSizeHints, flags} p :: IO CLong 1457 let whenBit n x = if testBit flags n then liftM Just x else return Nothing 1458 return SizeHints 1459 `ap` whenBit pMinSizeBit (do liftM2 (,) (#{peek XSizeHints, min_width } p) 1460 (#{peek XSizeHints, min_height } p)) 1461 `ap` whenBit pMaxSizeBit (do liftM2 (,) (#{peek XSizeHints, max_width } p) 1462 (#{peek XSizeHints, max_height } p)) 1463 `ap` whenBit pResizeIncBit (do liftM2 (,) (#{peek XSizeHints, width_inc } p) 1464 (#{peek XSizeHints, height_inc } p)) 1465 `ap` whenBit pAspectBit (do minx <- #{peek XSizeHints, min_aspect.x} p 1466 miny <- #{peek XSizeHints, min_aspect.y} p 1467 maxx <- #{peek XSizeHints, max_aspect.x} p 1468 maxy <- #{peek XSizeHints, max_aspect.y} p 1469 return ((minx, miny), (maxx, maxy))) 1470 `ap` whenBit pBaseSizeBit (do liftM2 (,) (#{peek XSizeHints, base_width } p) 1471 (#{peek XSizeHints, base_height} p)) 1472 `ap` whenBit pWinGravityBit (#{peek XSizeHints, win_gravity} p) 1473 1474 1475foreign import ccall unsafe "XlibExtras.h XGetWMNormalHints" 1476 xGetWMNormalHints :: Display -> Window -> Ptr SizeHints -> Ptr CLong -> IO Status 1477 1478getWMNormalHints :: Display -> Window -> IO SizeHints 1479getWMNormalHints d w 1480 = alloca $ \sh -> do 1481 alloca $ \supplied_return -> do 1482 -- what's the purpose of supplied_return? 1483 status <- xGetWMNormalHints d w sh supplied_return 1484 case status of 1485 0 -> return (SizeHints Nothing Nothing Nothing Nothing Nothing Nothing) 1486 _ -> peek sh 1487 1488 1489data ClassHint = ClassHint 1490 { resName :: String 1491 , resClass :: String 1492 } 1493 1494getClassHint :: Display -> Window -> IO ClassHint 1495getClassHint d w = allocaBytes (#{size XClassHint}) $ \ p -> do 1496 s <- xGetClassHint d w p 1497 if s /= 0 -- returns a nonzero status on success 1498 then do 1499 res_name_p <- #{peek XClassHint, res_name} p 1500 res_class_p <- #{peek XClassHint, res_class} p 1501 res <- liftM2 ClassHint (peekCString res_name_p) (peekCString res_class_p) 1502 _ <- xFree res_name_p 1503 _ <- xFree res_class_p 1504 return res 1505 else return $ ClassHint "" "" 1506 1507foreign import ccall unsafe "XlibExtras.h XGetClassHint" 1508 xGetClassHint :: Display -> Window -> Ptr ClassHint -> IO Status 1509 1510------------------------------------------------------------------------ 1511-- WM Hints 1512 1513-- These are the documented values for a window's "WM State", set, for example, 1514-- in wmh_initial_state, below. Note, you may need to play games with 1515-- fromIntegral and/or fromEnum. 1516withdrawnState,normalState, iconicState :: Int 1517withdrawnState = #{const WithdrawnState} 1518normalState = #{const NormalState} 1519iconicState = #{const IconicState} 1520 1521-- The following values are the documented bit positions on XWMHints's flags field. 1522-- Use testBit, setBit, and clearBit to manipulate the field. 1523inputHintBit,stateHintBit,iconPixmapHintBit,iconWindowHintBit,iconPositionHintBit,iconMaskHintBit,windowGroupHintBit,urgencyHintBit :: Int 1524inputHintBit = 0 1525stateHintBit = 1 1526iconPixmapHintBit = 2 1527iconWindowHintBit = 3 1528iconPositionHintBit = 4 1529iconMaskHintBit = 5 1530windowGroupHintBit = 6 1531urgencyHintBit = 8 1532 1533-- The following bitmask tests for the presence of all bits except for the 1534-- urgencyHintBit. 1535allHintsBitmask :: CLong 1536allHintsBitmask = #{const AllHints} 1537 1538data WMHints = WMHints 1539 { wmh_flags :: CLong 1540 , wmh_input :: Bool 1541 , wmh_initial_state :: CInt 1542 , wmh_icon_pixmap :: Pixmap 1543 , wmh_icon_window :: Window 1544 , wmh_icon_x :: CInt 1545 , wmh_icon_y :: CInt 1546 , wmh_icon_mask :: Pixmap 1547 , wmh_window_group :: XID 1548 } 1549 1550instance Storable WMHints where 1551 -- should align to the alignment of the largest type 1552 alignment _ = alignment (undefined :: CLong) 1553 sizeOf _ = #{size XWMHints} 1554 1555 peek p = return WMHints 1556 `ap` #{peek XWMHints, flags} p 1557 `ap` #{peek XWMHints, input} p 1558 `ap` #{peek XWMHints, initial_state} p 1559 `ap` #{peek XWMHints, icon_pixmap} p 1560 `ap` #{peek XWMHints, icon_window} p 1561 `ap` #{peek XWMHints, icon_x} p 1562 `ap` #{peek XWMHints, icon_x} p 1563 `ap` #{peek XWMHints, icon_mask} p 1564 `ap` #{peek XWMHints, window_group} p 1565 1566 poke p wmh = do 1567 #{poke XWMHints, flags} p $ wmh_flags wmh 1568 #{poke XWMHints, input} p $ wmh_input wmh 1569 #{poke XWMHints, initial_state} p $ wmh_initial_state wmh 1570 #{poke XWMHints, icon_pixmap} p $ wmh_icon_pixmap wmh 1571 #{poke XWMHints, icon_window} p $ wmh_icon_window wmh 1572 #{poke XWMHints, icon_x} p $ wmh_icon_x wmh 1573 #{poke XWMHints, icon_y} p $ wmh_icon_y wmh 1574 #{poke XWMHints, icon_mask} p $ wmh_icon_mask wmh 1575 #{poke XWMHints, window_group} p $ wmh_window_group wmh 1576 1577foreign import ccall unsafe "XlibExtras.h XGetWMHints" 1578 xGetWMHints :: Display -> Window -> IO (Ptr WMHints) 1579 1580getWMHints :: Display -> Window -> IO WMHints 1581getWMHints dpy w = do 1582 p <- xGetWMHints dpy w 1583 if p == nullPtr 1584 then return $ WMHints 0 False 0 0 0 0 0 0 0 1585 else do x <- peek p; _ <- xFree p; return x 1586 1587foreign import ccall unsafe "XlibExtras.h XAllocWMHints" 1588 xAllocWMHints :: IO (Ptr WMHints) 1589 1590foreign import ccall unsafe "XlibExtras.h XSetWMHints" 1591 xSetWMHints :: Display -> Window -> Ptr WMHints -> IO Status 1592 1593setWMHints :: Display -> Window -> WMHints -> IO Status 1594setWMHints dpy w wmh = do 1595 p_wmh <- xAllocWMHints 1596 poke p_wmh wmh 1597 res <- xSetWMHints dpy w p_wmh 1598 _ <- xFree p_wmh 1599 return res 1600 1601------------------------------------------------------------------------ 1602-- Keysym Macros 1603-- 1604-- Which we have to wrap in functions, then bind here. 1605 1606foreign import ccall unsafe "XlibExtras.h x11_extras_IsCursorKey" 1607 isCursorKey :: KeySym -> Bool 1608foreign import ccall unsafe "XlibExtras.h x11_extras_IsFunctionKey" 1609 isFunctionKey :: KeySym -> Bool 1610foreign import ccall unsafe "XlibExtras.h x11_extras_IsKeypadKey" 1611 isKeypadKey :: KeySym -> Bool 1612foreign import ccall unsafe "XlibExtras.h x11_extras_IsMiscFunctionKey" 1613 isMiscFunctionKey :: KeySym -> Bool 1614foreign import ccall unsafe "XlibExtras.h x11_extras_IsModifierKey" 1615 isModifierKey :: KeySym -> Bool 1616foreign import ccall unsafe "XlibExtras.h x11_extras_IsPFKey" 1617 isPFKey :: KeySym -> Bool 1618foreign import ccall unsafe "XlibExtras.h x11_extras_IsPrivateKeypadKey" 1619 isPrivateKeypadKey :: KeySym -> Bool 1620 1621------------------------------------------------------------------------------- 1622-- Selections 1623-- 1624foreign import ccall unsafe "HsXlib.h XSetSelectionOwner" 1625 xSetSelectionOwner :: Display -> Atom -> Window -> Time -> IO () 1626 1627foreign import ccall unsafe "HsXlib.h XGetSelectionOwner" 1628 xGetSelectionOwner :: Display -> Atom -> IO Window 1629 1630foreign import ccall unsafe "HsXlib.h XConvertSelection" 1631 xConvertSelection :: Display -> Atom -> Atom -> Atom -> Window -> Time -> IO () 1632 1633------------------------------------------------------------------------------- 1634-- Error handling 1635-- 1636type XErrorEventPtr = Ptr () 1637type CXErrorHandler = Display -> XErrorEventPtr -> IO CInt 1638type XErrorHandler = Display -> XErrorEventPtr -> IO () 1639 1640data ErrorEvent = ErrorEvent { 1641 ev_type :: !CInt, 1642 ev_display :: Display, 1643 ev_serialnum :: !CULong, 1644 ev_error_code :: !CUChar, 1645 ev_request_code :: !CUChar, 1646 ev_minor_code :: !CUChar, 1647 ev_resourceid :: !XID 1648} 1649 1650foreign import ccall safe "wrapper" 1651 mkXErrorHandler :: CXErrorHandler -> IO (FunPtr CXErrorHandler) 1652foreign import ccall safe "dynamic" 1653 getXErrorHandler :: FunPtr CXErrorHandler -> CXErrorHandler 1654foreign import ccall safe "HsXlib.h XSetErrorHandler" 1655 _xSetErrorHandler :: FunPtr CXErrorHandler -> IO (FunPtr CXErrorHandler) 1656 1657-- |A binding to XSetErrorHandler. 1658-- NOTE: This is pretty experimental because of safe vs. unsafe calls. I 1659-- changed sync to a safe call, but there *might* be other calls that cause a 1660-- problem 1661setErrorHandler :: XErrorHandler -> IO () 1662setErrorHandler new_handler = do 1663 _handler <- mkXErrorHandler (\d -> \e -> new_handler d e >> return 0) 1664 _ <- _xSetErrorHandler _handler 1665 return () 1666 1667-- |Retrieves error event data from a pointer to an XErrorEvent and 1668-- puts it into an ErrorEvent. 1669getErrorEvent :: XErrorEventPtr -> IO ErrorEvent 1670getErrorEvent ev_ptr = do 1671 _type <- #{peek XErrorEvent, type } ev_ptr 1672 serial <- #{peek XErrorEvent, serial} ev_ptr 1673 dsp <- fmap Display (#{peek XErrorEvent, display} ev_ptr) 1674 error_code <- #{peek XErrorEvent, error_code} ev_ptr 1675 request_code <- #{peek XErrorEvent, request_code} ev_ptr 1676 minor_code <- #{peek XErrorEvent, minor_code} ev_ptr 1677 resourceid <- #{peek XErrorEvent, resourceid} ev_ptr 1678 return $ ErrorEvent { 1679 ev_type = _type, 1680 ev_display = dsp, 1681 ev_serialnum = serial, 1682 ev_error_code = error_code, 1683 ev_request_code = request_code, 1684 ev_minor_code = minor_code, 1685 ev_resourceid = resourceid 1686 } 1687 1688-- |A binding to XMapRaised. 1689foreign import ccall unsafe "HsXlib.h XMapRaised" 1690 mapRaised :: Display -> Window -> IO CInt 1691 1692foreign import ccall unsafe "HsXlib.h XGetCommand" 1693 xGetCommand :: Display -> Window -> Ptr (Ptr CWString) -> Ptr CInt -> IO Status 1694 1695getCommand :: Display -> Window -> IO [String] 1696getCommand d w = 1697 alloca $ 1698 \argvp -> 1699 alloca $ 1700 \argcp -> 1701 do 1702 _ <- throwIf (success >) (\status -> "xGetCommand returned status: " ++ show status) $ xGetCommand d w argvp argcp 1703 argc <- peek argcp 1704 argv <- peek argvp 1705 texts <- flip mapM [0 .. fromIntegral $ pred argc] $ \i -> peekElemOff argv i >>= peekCWString 1706 wcFreeStringList argv 1707 return texts 1708 1709foreign import ccall unsafe "HsXlib.h XGetModifierMapping" 1710 xGetModifierMapping :: Display -> IO (Ptr ()) 1711 1712foreign import ccall unsafe "HsXlib.h XFreeModifiermap" 1713 xFreeModifiermap :: Ptr () -> IO (Ptr CInt) 1714 1715getModifierMapping :: Display -> IO [(Modifier, [KeyCode])] 1716getModifierMapping d = do 1717 p <- xGetModifierMapping d 1718 m' <- #{peek XModifierKeymap, max_keypermod} p :: IO CInt 1719 let m = fromIntegral m' 1720 pks <- #{peek XModifierKeymap, modifiermap} p :: IO (Ptr KeyCode) 1721 ks <- peekArray (m * 8) pks 1722 _ <- xFreeModifiermap p 1723 return . zip masks . map fst . tail . iterate (splitAt m . snd) $ ([], ks) 1724 where 1725 masks = [shiftMapIndex .. mod5MapIndex] 1726