Wire Qt drag and drop handling
ober
c235fdf4412030d30931282fb02c606637e69ab1
--- a/src/jerboa-emacs/qt/app.ss +++ b/src/jerboa-emacs/qt/app.ss @@ -2,7 +2,8 @@ ;;; Qt application and event loop for jemacs (export qt-main qt-open-file! qt-do-init! - qt-call-with-key-handler-errors) + qt-call-with-key-handler-errors + qt-drop-payload-file-paths qt-handle-drop-text!) (import :std/sugar :std/misc/string @@ -381,7 +382,8 @@ name (if path (string-append " - " path) "") " - jemacs"))) - (qt-main-window-set-title! win title))) + (when win + (qt-main-window-set-title! win title)))) (def (qt-update-mark-selection! app) "Update visual selection to reflect active mark region. @@ -920,6 +922,7 @@ (def (qt-refresh-after-key! app echo-label origin) (let* ((fr (app-state-frame app)) (trace? (eq? (buffer-lexer-lang (qt-current-buffer fr)) 'dired))) + (qt-ensure-drop-filter! app (qt-current-editor fr)) (when trace? (qt-ui-trace (string-append origin " refresh begin"))) (when trace? (qt-ui-trace (string-append origin " visual begin"))) (qt-update-visual-decorations! (qt-current-editor fr)) @@ -1013,6 +1016,11 @@ ;; Store tab bar references for dynamic updates (set! *tab-bar-layout* tab-layout) (set! *tab-bar-widget* tab-bar) + ;; Accept file/text drops in the editor area. + (qt-ensure-drop-filter! app win) + (qt-ensure-drop-filter! app central) + (qt-ensure-drop-filter! app splitter) + (qt-ensure-drop-filter! app (qt-current-editor fr)) ;; Echo label: ensure visible with minimum height and distinct style ;; Must be tall enough to display text clearly (not clipped) @@ -2476,6 +2484,89 @@ (qt-app-destroy! qt-app))))) ;;;============================================================================ +;;; Drag and drop helpers +;;;============================================================================ + +(def *qt-drop-filters* (make-hash-table)) + +(def (qt-hex-digit-value ch) + (cond + ((and (char>=? ch #\0) (char<=? ch #\9)) + (- (char->integer ch) (char->integer #\0))) + ((and (char>=? ch #\a) (char<=? ch #\f)) + (+ 10 (- (char->integer ch) (char->integer #\a)))) + ((and (char>=? ch #\A) (char<=? ch #\F)) + (+ 10 (- (char->integer ch) (char->integer #\A)))) + (else #f))) + +(def (qt-percent-decode text) + "Decode percent escapes in a file URI path. Invalid escapes are left literal." + (let ((len (string-length text))) + (let loop ((i 0) (out '())) + (cond + ((>= i len) (list->string (reverse out))) + ((and (char=? (string-ref text i) #\%) + (< (+ i 2) len)) + (let ((hi (qt-hex-digit-value (string-ref text (+ i 1)))) + (lo (qt-hex-digit-value (string-ref text (+ i 2))))) + (if (and hi lo) + (loop (+ i 3) (cons (integer->char (+ (* hi 16) lo)) out)) + (loop (+ i 1) (cons (string-ref text i) out))))) + (else + (loop (+ i 1) (cons (string-ref text i) out))))))) + +(def (qt-drop-file-uri->path uri) + "Convert a file:// URI from a Qt text drop into a local path." + (let* ((body (substring uri 7 (string-length uri))) + (localhost? (and (>= (string-length body) 10) + (string=? (substring body 0 10) "localhost/"))) + (path (if localhost? + (substring body 9 (string-length body)) + body))) + (qt-percent-decode path))) + +(def (qt-drop-payload-file-paths text) + "Return file paths from a URI-list style drop payload, or #f for plain text." + (let loop ((lines (string-split text #\newline)) + (paths '()) + (saw-file? #f)) + (cond + ((null? lines) (and saw-file? (reverse paths))) + ((string-empty? (string-trim (car lines))) + (loop (cdr lines) paths saw-file?)) + ((string-prefix? "file://" (string-trim (car lines))) + (loop (cdr lines) + (cons (qt-drop-file-uri->path (string-trim (car lines))) paths) + #t)) + (else #f)))) + +(def (qt-handle-drop-text! app text) + "Handle a Qt drop payload: file URI lists open files; other text inserts." + (let ((paths (qt-drop-payload-file-paths text))) + (if paths + (begin + (for-each (lambda (path) (qt-open-file! app path)) paths) + (echo-message! (app-state-echo app) + (string-append "Dropped " (number->string (length paths)) " file(s)"))) + (let ((ed (qt-current-editor (app-state-frame app)))) + (when ed + (qt-plain-text-edit-insert-text! ed text) + (qt-update-visual-decorations! ed) + (qt-update-mark-selection! app) + (when (qt-frame-main-win (app-state-frame app)) + (qt-modeline-update! app) + (qt-update-frame-title! app)) + (qt-tabbar-update! app)))))) + +(def (qt-ensure-drop-filter! app widget) + "Install the Qt drop filter on WIDGET once." + (when (and widget (not (hash-get *qt-drop-filters* widget))) + (qt-widget-set-accept-drops! widget #t) + (hash-put! *qt-drop-filters* widget + (qt-drop-filter-install! widget + (lambda (text) (qt-handle-drop-text! app text)))))) + +;;;============================================================================ ;;; File opening helper ;;;============================================================================ --- a/tests/test-qt-part2.ss +++ b/tests/test-qt-part2.ss @@ -17,7 +17,9 @@ (jerboa-emacs snippets) (jerboa-emacs qt sci-shim) (jerboa-emacs qt window) - (only (jerboa-emacs qt app) qt-call-with-key-handler-errors qt-open-file!) + (only (jerboa-emacs qt app) + qt-call-with-key-handler-errors qt-open-file! + qt-drop-payload-file-paths qt-handle-drop-text!) (only (jerboa-emacs qt echo) qt-minibuffer-history-reset! qt-minibuffer-history-record! @@ -145,6 +147,18 @@ (check (qt-plain-text-edit-text ed) => "aXb") (check (app-state-last-yank-pos app) => 1) (check (app-state-last-yank-len app) => 1))) +(test-case "group46c drop payload parser handles file URIs" + (check (qt-drop-payload-file-paths + "file:///tmp/a%20b.ss\nfile://localhost/Users/user/c.ss\r\n") + => '("/tmp/a b.ss" "/Users/user/c.ss")) + (check (qt-drop-payload-file-paths "plain dropped text") => #f)) + +(test-case "group46d drop plain text inserts at point" + (let-values (((ed w app) (make-qt-test-app "part2-46d"))) + (qt-plain-text-edit-set-text! ed "ab") + (sci-send ed SCI_GOTOPOS 1) + (qt-handle-drop-text! app "DROP") + (check (qt-plain-text-edit-text ed) => "aDROPb"))) (test-case "group47 scroll commands page the Scintilla viewport" (let-values (((ed w app) (make-qt-test-app "part2-47")))