racket/gui: add `get-current-mouse-state'

collects/mred/mred-sig.rkt

@@ -78,6 +78,7 @@ frame%
 gauge%
 get-choices-from-user
 get-color-from-user
+get-current-mouse-state
 get-default-shortcut-prefix
 get-directory
 get-display-count

collects/mred/private/mred.rkt

@@ -116,6 +116,7 @@
 	     event-dispatch-handler
 	     eventspace?
 	     flush-display
+             get-current-mouse-state
 	     get-highlight-background-color
              get-highlight-text-color
 	     get-the-editor-data-class-list

collects/mred/private/wx/cocoa/platform.rkt

@@ -63,6 +63,7 @@
    display-origin
    display-count
    flush-display
+   get-current-mouse-state
    fill-private-color
    cancel-quit
    get-control-font-face

collects/mred/private/wx/cocoa/procs.rkt

@@ -6,6 +6,7 @@
          ffi/unsafe
          ffi/unsafe/objc
          "utils.rkt"
+         "const.rkt"
          "types.rkt"
          "frame.rkt"
          "window.rkt"
@@ -63,9 +64,10 @@
  file-creator-and-type
  file-selector
  key-symbol-to-menu-key
- needs-grow-box-spacer?)
+ needs-grow-box-spacer?
+ get-current-mouse-state)
 
-(import-class NSScreen NSCursor NSMenu)
+(import-class NSScreen NSCursor NSMenu NSEvent)
 
 (define (find-graphical-system-path what)
   #f)
@@ -192,3 +194,28 @@
 
 (define (needs-grow-box-spacer?)
   (not (version-10.7-or-later?)))
+
+;; ------------------------------------------------------------
+;; Mouse and modifier-key state
+
+(define (get-current-mouse-state)
+  (define posn (tell #:type _NSPoint NSEvent mouseLocation))
+  (define buttons (tell #:type _NSUInteger NSEvent pressedMouseButtons))
+  (define mods (tell #:type _NSUInteger NSEvent modifierFlags))
+  (define (maybe v mask sym)
+    (if (zero? (bitwise-and v mask))
+        null
+        (list sym)))
+  (define h (let ([f (tell #:type _NSRect (tell NSScreen mainScreen) frame)])
+              (NSSize-height (NSRect-size f))))
+  (values (make-object point% 
+                       (->long (NSPoint-x posn))
+                       (->long (- (- h (NSPoint-y posn)) (get-menu-bar-height))))
+          (append
+           (maybe buttons #x1 'left)
+           (maybe buttons #x2 'right)
+           (maybe mods NSShiftKeyMask 'shift)
+           (maybe mods NSCommandKeyMask 'meta)
+           (maybe mods NSAlternateKeyMask 'alt)
+           (maybe mods NSControlKeyMask 'control)
+           (maybe mods NSAlphaShiftKeyMask 'caps))))

collects/mred/private/wx/gtk/frame.rkt

@@ -22,7 +22,8 @@
               display-origin
               display-size
 	      display-count
-              location->window))
+              location->window
+              get-current-mouse-state))
 
 ;; ----------------------------------------
 
@@ -57,6 +58,13 @@
 (define-gtk gtk_window_resize (_fun _GtkWidget _int _int -> _void))
 
 (define-gdk gdk_window_set_cursor (_fun _GdkWindow _pointer -> _void))
+(define-gdk gdk_screen_get_root_window (_fun _GdkScreen -> _GdkWindow))
+(define-gdk gdk_window_get_pointer (_fun _GdkWindow 
+                                         (x : (_ptr o _int))
+                                         (y : (_ptr o _int))
+                                         (mods : (_ptr o _uint))
+                                         -> _GdkWindow
+                                         -> (values x y mods)))
 
 (define-gtk gtk_window_iconify (_fun _GtkWindow -> _void))
 (define-gtk gtk_window_deiconify (_fun _GtkWindow -> _void))
@@ -543,3 +551,24 @@
                  [fh (send f get-height)])
              (<= fy y (+ fy fh)))
            f))))
+
+;; ----------------------------------------
+
+(define (get-current-mouse-state)
+  (define-values (x y mods) (gdk_window_get_pointer
+                             (gdk_screen_get_root_window
+                              (gdk_screen_get_default))))
+  (define (maybe mask sym)
+    (if (zero? (bitwise-and mods mask))
+        null
+        (list sym)))
+  (values (make-object point% x y)
+          (append
+           (maybe GDK_BUTTON1_MASK 'left)
+           (maybe GDK_BUTTON2_MASK 'middle)
+           (maybe GDK_BUTTON3_MASK 'right)
+           (maybe GDK_SHIFT_MASK 'shift)
+           (maybe GDK_LOCK_MASK 'caps)
+           (maybe GDK_CONTROL_MASK 'control)
+           (maybe GDK_MOD1_MASK 'alt)
+           (maybe GDK_META_MASK 'meta))))

collects/mred/private/wx/gtk/platform.rkt

@@ -64,6 +64,7 @@
    display-origin
    display-count
    flush-display
+   get-current-mouse-state
    fill-private-color
    cancel-quit
    get-control-font-face

collects/mred/private/wx/platform.rkt

@@ -50,6 +50,7 @@
                 display-origin
 		display-count
                 flush-display
+                get-current-mouse-state
                 fill-private-color
                 cancel-quit
                 get-control-font-face

collects/mred/private/wx/win32/platform.rkt

@@ -64,6 +64,7 @@
    display-origin
    display-count
    flush-display
+   get-current-mouse-state
    fill-private-color
    cancel-quit
    get-control-font-face

collects/mred/private/wx/win32/procs.rkt

@@ -43,6 +43,7 @@
   get-highlight-text-color
   check-for-break)
  flush-display
+ get-current-mouse-state
  fill-private-color
  play-sound
  location->window
@@ -116,3 +117,26 @@
 (define (check-for-break) #f)
 
 (define (needs-grow-box-spacer?) #f)
+
+(define-user32 GetCursorPos (_wfun (p : (_ptr o _POINT)) -> (r : _BOOL)
+                                   -> (if r
+                                          p
+                                          (failed 'GetCursorPos))))
+(define-user32 GetAsyncKeyState (_wfun _int -> _SHORT))
+(define-user32 GetSystemMetrics (_wfun _int -> _int))
+(define SM_SWAPBUTTON 23)
+(define (get-current-mouse-state)
+  (define p (GetCursorPos))
+  (define (maybe vk sym)
+    (if (negative? (GetAsyncKeyState vk))
+        (list sym)
+        null))
+  (define swapped? (not (zero? (GetSystemMetrics SM_SWAPBUTTON))))
+  (values (make-object point% (POINT-x p) (POINT-y p))
+          (append
+           (maybe (if swapped? VK_RBUTTON VK_LBUTTON) 'left)
+           (maybe (if swapped? VK_LBUTTON VK_RBUTTON) 'right)
+           (maybe VK_LSHIFT 'shift)
+           (maybe VK_CONTROL 'control)
+           (maybe VK_MENU 'alt)
+           (maybe VK_CAPITAL 'caps))))

collects/scribblings/gui/miscwin-funcs.scrbl

@@ -194,6 +194,15 @@ break is sent (via @racket[break-thread]) to the created eventspace's
 @tech{handler thread}.}
 
 
+@defproc[(get-current-mouse-state) (values (is-a?/c point%)
+                                           (listof (or/c 'left 'middle 'right
+                                                         'shift 'control 'alt 'meta 'caps)))]{
+
+Returns the current location of the mouse in screen coordinates,
+and returns a list of symbols for mouse buttons and modifier keys
+that are currently pressed.}
+
+
 @defproc[(hide-cursor-until-moved) void?]{
 
 Hides the cursor until the user moves the mouse or clicks the mouse

collects/tests/gracket/item.rkt

@@ -2289,6 +2289,30 @@
 	    '(arrow bullseye cross hand ibeam watch blank size-n/s size-e/w size-ne/sw size-nw/se))
   (send f show #t))
 
+;----------------------------------------------------------------------
+
+(define (mouse)
+  (define f (new frame% 
+                 [label "Mouse"]
+                 [width 300]
+                 [height 200]))
+  (define m (new message%
+                 [parent f]
+                 [label ""]
+                 [stretchable-width #t]))
+  (send f show #t)
+  (thread (lambda ()
+            (let loop ()
+              (when (send f is-shown?)
+                (sleep 0.1)
+                (define-values (pos keys) (get-current-mouse-state))
+                (queue-callback
+                 (lambda () (send m set-label
+                                  (format "~a,~a ~a" 
+                                          (send pos get-x)
+                                          (send pos get-y)
+                                          keys))))
+                (loop))))))
 
 ;----------------------------------------------------------------------
 
@@ -2370,6 +2394,8 @@
 (make-object vertical-pane% crp) ; filler
 (make-object button% "Cursors" crp (lambda (b e) (cursors)))
 (make-object vertical-pane% crp) ; filler
+(make-object button% "Mouse" crp (lambda (b e) (mouse)))
+(make-object vertical-pane% crp) ; filler
 (make-object button% "Make Radiobox Frame" crp (lambda (b e) (radiobox-frame)))
 (define cp (make-object horizontal-pane% ap))
 (send cp stretchable-width #f)

doc/release-notes/racket/HISTORY.txt

@@ -1,3 +1,6 @@
+Version 5.3.1.5
+racket/gui: added get-current-mouse-state
+
 Version 5.3.1.2
 compiler/zo-structs: added a constantness field to module-variable