`Navigate' the menus with a search-list-box (quickscript)

command-palette.rkt

#lang racket/base

(require quickscript
         racket/gui/base
         racket/class
         racket/list
         search-list-box)

(provide (except-out (all-defined-out)
                     search-list-box-filter))

;;; Author: Laurent Orseau https://github.com/Metaxal
;;; License: [Apache License, Version 2.0](http://www.apache.org/licenses/LICENSE-2.0) or
;;;          [MIT license](http://opensource.org/licenses/MIT) at your option.

(script-help-string "`Navigate' the menus with a search-list-box")

(define (make-menu-palette top-item)
  (define contents '())
  (let loop ([item top-item] [path ""])
    (cond [(or (is-a? item menu-item-container<%>))
           (define new-path
             (if (is-a? item labelled-menu-item<%>)
               (string-append path (send item get-plain-label) "|")
               path))
           (for-each (λ (ch) (loop ch new-path)) (send item get-items))]
          [(is-a? item menu-item%)
           (define new-path (string-append path (send item get-plain-label)))
           (define callback (λ () (send item command (new control-event% [event-type 'menu]))))
           (set! contents (cons (list new-path callback)
                                contents))]))
  (reverse contents))

(define (make-button-palette top-wnd)
  (define contents '())
  (let loop ([obj top-wnd])
    (cond [(or (is-a? obj area-container<%>))
           (for-each loop (send obj get-children))]
          [(and (object-method-arity-includes? obj 'get-button-label 0)
                (object-method-arity-includes? obj 'command 0))
           ; probably a switchable-button%
           ; can't test (for now) with `is-a?` because the mrlib module is not
           ; shared with drracket
           (define (callback) (send obj command))
           (set! contents (cons (list (send obj get-button-label) callback) 
                                contents))]
          [(is-a? obj button%)
           ; racket/gui is shared with drracket, so we can test button%
           (define (callback) (send obj command (new control-event% [event-type 'button])))
           (set! contents (cons (list (send obj get-plain-label) callback)
                                contents))]))
  (reverse contents))

;; Use word-filter if exists, otherwise revert to default
;; This is *not* a function, to avoid being call within Quickscript's namespace,
;; where search-list-box is not defined (not sure why it doesn't work though).
(define search-list-box-filter
  (let-values ([(l1 l2) (module->exports 'search-list-box)])
    (if (memq 'word-filter (flatten (cons l1 l2)))
      word-filter
      default-filter)))

;; wnd: the window that originally had the focus, to restore the focus
;; before calling the callback.
(define (show-palette contents
                      #:label [label "Command palette"]
                      #:orig-focus [wnd #f]
                      #:parent [parent #f])
  (define slb
    (new search-list-box-frame% ; todo: maybe should be a dialog (think tiling wms)
         [parent parent]
         [label label]
         [width 800]
         [contents contents]
         [key first]
         [filter search-list-box-filter]
         [callback (λ (idx label content)
                     (when idx
                       (send slb show #f)
                       (when wnd (send wnd focus)
                         ; Busy loop to make sure the window has the focus.
                         ; Don't wait more than 0.5s to avoid deadlocking in case of problem.
                         (let ([wait-seconds 0.02] [wait-max 0.5])
                           (let loop ([waited 0])
                             (unless (or (send wnd has-focus?) (> waited wait-max))
                               (sleep/yield wait-seconds)
                               (loop (+ waited wait-seconds))))))
                       (define callback (second content))
                       (queue-callback callback)))]
         [show? #f]))
  (send slb center)
  (send slb show #t)
  slb)

;====================;
;=== Quickscripts ===;
;====================;

(define-script command-palette
  #:label "All menus"
  #:menu-path ("Command &palette")
  #:shortcut f4
  #:shortcut-prefix () ; empty, because default is (ctrl)
  (λ (selection #:frame drfr)
    (define slb (show-palette (make-menu-palette (send drfr get-menu-bar))
                              #:parent drfr
                              #:orig-focus (send drfr get-focus-window)))
    #f))

(define-script command-palette-scripts
  #:label "Scripts menu only"
  #:menu-path ("Command &palette")
  #:shortcut f4
  #:shortcut-prefix (shift)
  (λ (selection #:frame drfr)
    (define items (send (send drfr get-menu-bar) get-items))
    (define script-menu
      (findf (λ (it) (and (is-a? it menu%)
                          (equal? (send it get-plain-label) "Scripts")))
             items))
    (define slb (show-palette (make-menu-palette script-menu)
                              #:label "Command palette (Scripts menu)"
                              #:parent drfr
                              #:orig-focus (send drfr get-focus-window)))
    #f))

(define-script command-palette-buttons
  #:label "Buttons"
  #:menu-path ("Command &palette")
  ;#:shortcut f4
  ;#:shortcut-prefix () ; empty, because default is (ctrl)
  (λ (selection #:frame drfr)
    (define slb (show-palette (make-button-palette drfr)
                              #:label "Command palette (buttons)"
                              #:parent drfr
                              #:orig-focus (send drfr get-focus-window)))
    #f))

(module url2script-info racket/base
  (provide filename url)
  (define filename "command-palette.rkt")
  (define url "https://gist.github.com/Metaxal/d06f50a2534ca229309e71a2d244a912"))

By default:
F4: command palette for the all DrRacket menus
Shift-F4: command palette for the Scripts menu only

There's also a palette for all the buttons found in the DrRacket frame. (no keybinding associated to this at the moment.):

Requires the search-list-box package.