Implement Qt run-with-timer
ober
fb4474ed6be5bfd6420efb3c3a4ed5db494b1d10
--- a/src/jerboa-emacs/async.ss +++ b/src/jerboa-emacs/async.ss @@ -218,25 +218,53 @@ ;; Each task: (name interval-ms last-run-ms thunk) (def *scheduled-tasks* '()) +(def *cancelled-scheduled-tasks* '()) (def (current-time-ms) "Current wall-clock time in milliseconds." (inexact->exact (floor (* (time->seconds (current-time)) 1000)))) +(def (scheduled-task-cancelled? name) + (memq name *cancelled-scheduled-tasks*)) + (def (schedule-periodic! name interval-ms thunk) "Register a periodic task to run at the given interval. Tasks are run by master-timer-tick! on the UI thread." - ;; Remove any existing task with the same name first + ;; Remove any existing task with the same name first. + (set! *cancelled-scheduled-tasks* + (filter (lambda (n) (not (eq? n name))) *cancelled-scheduled-tasks*)) (set! *scheduled-tasks* (filter (lambda (t) (not (eq? (car t) name))) *scheduled-tasks*)) (set! *scheduled-tasks* (cons (list name interval-ms 0 thunk) *scheduled-tasks*))) (def (cancel-periodic! name) - "Remove a periodic task by name." + "Remove a periodic task by name. Also survives cancellation from inside a timer thunk." + (unless (scheduled-task-cancelled? name) + (set! *cancelled-scheduled-tasks* (cons name *cancelled-scheduled-tasks*))) (set! *scheduled-tasks* (filter (lambda (t) (not (eq? (car t) name))) *scheduled-tasks*))) +(def (run-scheduled-task now task) + (let ((name (car task)) + (interval (cadr task)) + (last (caddr task)) + (thunk (cadddr task))) + (if (or (scheduled-task-cancelled? name) + (< (- now last) interval)) + task + (begin + (verbose-log! "TICK " (symbol->string name) " begin") + (with-catch + (lambda (e) + (verbose-log! "TIMER-ERROR in " + (symbol->string name) ": " + (with-output-to-string + (lambda () (display-exception e))))) + thunk) + (verbose-log! "TICK " (symbol->string name) " end") + (list name interval now thunk))))) + (def (master-timer-tick!) "Master timer callback: drain the UI queue, run periodic tasks, cleanup GC'd resources. Should be called from a single Qt timer at ~16-50ms interval." @@ -247,25 +275,10 @@ ;; 3. Run periodic tasks whose interval has elapsed (let ((now (current-time-ms))) (set! *scheduled-tasks* - (map (lambda (task) - (let ((name (car task)) - (interval (cadr task)) - (last (caddr task)) - (thunk (cadddr task))) - (if (>= (- now last) interval) - (begin - (verbose-log! "TICK " (symbol->string name) " begin") - (with-catch - (lambda (e) - (verbose-log! "TIMER-ERROR in " - (symbol->string name) ": " - (with-output-to-string - (lambda () (display-exception e))))) - thunk) - (verbose-log! "TICK " (symbol->string name) " end") - (list name interval now thunk)) - task))) - *scheduled-tasks*)))) + (filter (lambda (task) (not (scheduled-task-cancelled? (car task)))) + (map (lambda (task) (run-scheduled-task now task)) + *scheduled-tasks*))) + (set! *cancelled-scheduled-tasks* '()))) ;;;============================================================================ ;;; Async Process Runner --- a/src/jerboa-emacs/qt/commands-parity5.ss +++ b/src/jerboa-emacs/qt/commands-parity5.ss @@ -1329,8 +1329,73 @@ (execute-command! app 'add-abbrev)) (def (cmd-apheleia-format-buffer app) (execute-command! app 'format-buffer)) +(def *qt-run-with-timer-counter* 0) + +(def (next-run-with-timer-name!) + "Return a unique scheduler name for an interactive run-with-timer task." + (set! *qt-run-with-timer-counter* (+ *qt-run-with-timer-counter* 1)) + (string->symbol + (string-append "run-with-timer-" + (number->string (current-time-ms)) + "-" + (number->string *qt-run-with-timer-counter*)))) + +(def (timer-blank? text) + (or (not text) (string-empty? text))) + +(def (timer-seconds->milliseconds text) + "Parse a non-negative seconds string as milliseconds, or #f." + (let ((n (and (not (timer-blank? text)) (string->number text)))) + (and n (>= n 0) + (inexact->exact (floor (* n 1000)))))) + +(def (timer-run-command! app echo command command-text) + (with-catch + (lambda (e) + (echo-message! echo + (string-append "Timer command failed: " command-text))) + (lambda () + (execute-command! app command)))) + +(def (schedule-user-timer! app echo delay-ms repeat-ms command-text) + (let ((name (next-run-with-timer-name!)) + (command (string->symbol command-text)) + (repeat (and repeat-ms (> repeat-ms 0) repeat-ms)) + (due (+ (current-time-ms) delay-ms))) + (schedule-periodic! name 50 + (lambda () + (let ((now (current-time-ms))) + (when (>= now due) + (unless repeat + (cancel-periodic! name)) + (timer-run-command! app echo command command-text) + (when repeat + (set! due (+ now repeat))))))) + repeat)) + (def (cmd-run-with-timer app) - (echo-message! (app-state-echo app) "Timers: not available interactively")) + "Run an interactive command after a delay, optionally repeating." + (let* ((echo (app-state-echo app)) + (delay-text (qt-echo-read-string app "Delay seconds: ")) + (delay-ms (timer-seconds->milliseconds delay-text))) + (cond + ((not delay-ms) + (echo-message! echo "Timer delay must be a non-negative number")) + (else + (let* ((repeat-text (qt-echo-read-string app "Repeat seconds (blank or 0 for once): ")) + (repeat-ms (timer-seconds->milliseconds repeat-text)) + (command-text (qt-echo-read-string app "Command: "))) + (cond + ((timer-blank? command-text) + (echo-message! echo "Timer command is required")) + ((and (not (timer-blank? repeat-text)) (not repeat-ms)) + (echo-message! echo "Timer repeat must be blank, zero, or a non-negative number")) + (else + (let ((repeat (schedule-user-timer! app echo delay-ms repeat-ms command-text))) + (echo-message! echo + (if repeat + (string-append "Timer set: " command-text " every " repeat-text " seconds") + (string-append "Timer set: " command-text " in " delay-text " seconds"))))))))))) (def (cmd-ibuffer-mark app) (execute-command! app 'ibuffer)) (def (cmd-ibuffer-delete app) --- a/tests/test-qt-part2.ss +++ b/tests/test-qt-part2.ss @@ -17,6 +17,8 @@ (jerboa-emacs qt sci-shim) (jerboa-emacs qt window) (jerboa-emacs qt commands) + (only (jerboa-emacs qt commands-parity5) schedule-user-timer!) + (only (jerboa-emacs async) master-timer-tick!) (jerboa-emacs qt keymap) (jerboa-scintilla constants)) @@ -87,7 +89,7 @@ (qt-plain-text-edit-set-text! ed "") (values ed w app))) -(display "\n=== Qt Part2 Groups 44-53 ===\n") +(display "\n=== Qt Part2 Groups 44-54 ===\n") (test-case "group44 qt key fidelity" (check (qt-key-event->string QT_KEY_RETURN 0 "") => "C-m") @@ -147,9 +149,18 @@ (execute-command! app 'increment-hex-at-point) (check (not (not (string-contains (qt-plain-text-edit-text ed) "0x100"))) => #t))) +(test-case "group54 run-with-timer schedules one-shot UI command" + (let-values (((ed w app) (make-qt-test-app "part2-54"))) + (qt-plain-text-edit-set-text! ed "abc") + (sci-send ed SCI_GOTOPOS 0) + (schedule-user-timer! app (app-state-echo app) 0 #f "forward-char") + (master-timer-tick!) + (master-timer-tick!) + (check (sci-send ed SCI_GETCURRENTPOS) => 1))) + (newline) (let ([total (+ *pass* *fail*)]) - (printf "Part2 results: ~a/~a tests passed (groups 44-53)~n" *pass* total) + (printf "Part2 results: ~a/~a tests passed (groups 44-54)~n" *pass* total) (when (> *fail* 0) (printf "FAILED: ~a test(s)~n" *fail*)) (when (= *fail* 0)