From 733213fde9cf021c7e4d546245eeaff3fc9db802 Mon Sep 17 00:00:00 2001 From: Greg Hendershott Date: Wed, 24 Jan 2024 10:39:14 -0500 Subject: [PATCH] Use macro-debugger stepper for expressions, too Simplify back end implementation. Allow racket-expand-hiding policy to affect expression expansion, too. --- racket-stepper.el | 69 +++++++++++----------- racket/command-server.rkt | 2 +- racket/commands/macro.rkt | 89 ++++++++++------------------ test/racket-tests.el | 119 +++++++++++++++++++------------------- 4 files changed, 123 insertions(+), 156 deletions(-) diff --git a/racket-stepper.el b/racket-stepper.el index 5d09126e..f8f639db 100644 --- a/racket-stepper.el +++ b/racket-stepper.el @@ -76,11 +76,10 @@ were \\='disabled." (interactive "P") (racket--assert-edit-mode) (racket--save-if-changed) - (racket-stepper--start 'file - (racket--buffer-file-name) + (racket-stepper--start nil no-hiding)) -(defun racket-expand-region (start end &optional no-hiding) +(defun racket-expand-region (&optional no-hiding) "Expand the active region using `racket-stepper-mode'. Uses Racket's `expand-once` in the namespace from the most recent @@ -88,13 +87,14 @@ Uses Racket's `expand-once` in the namespace from the most recent With \\[universal-argument] behaves as if `racket-expand-hiding' were \\='disabled." - (interactive "rP") + (interactive "P") (unless (region-active-p) (user-error "No region")) - (racket--assert-sexp-edit-mode) + (racket--assert-edit-mode) (racket-stepper--expand-text no-hiding (lambda () - (cons start end)))) + (cons (region-beginning) + (region-end))))) (defun racket-expand-definition (&optional no-hiding) "Expand the definition around point using `racket-stepper-mode'. @@ -131,8 +131,7 @@ were \\='disabled." (defun racket-stepper--expand-text (no-hiding get-region) (pcase (funcall get-region) (`(,beg . ,end) - (racket-stepper--start 'expr - (buffer-substring-no-properties beg end) + (racket-stepper--start (buffer-substring-no-properties beg end) no-hiding)))) (defvar racket--stepper-repl-session-id nil @@ -141,36 +140,36 @@ were \\='disabled." May be nil for \"file\" stepping, but must be valid for \"expr\" stepping.") -(defun racket-stepper--start (which str no-hiding) +(defun racket-stepper--start (expression-str no-hiding) "Ensure buffer and issue initial command. -WHICH should be \"expr\" or \"file\". -STR should be the expression or pathname." + +STR should be the expression or nil for file expansion." (racket--assert-edit-mode) (setq racket--stepper-repl-session-id (racket--repl-session-id)) - (unless (or racket--stepper-repl-session-id - (eq which 'file)) - (error "Only works when the edit buffer has a REPL buffer, and, you should racket-run first")) - ;; Create buffer if necessary - (let ((name (racket--stepper-buffer-name))) - (unless (get-buffer name) - (with-current-buffer (get-buffer-create name) - (racket-stepper-mode))) - ;; Give it a window if necessary - (unless (get-buffer-window name) - (pop-to-buffer (get-buffer name))) - ;; Select the stepper window and insert - (select-window (get-buffer-window name)) - (let ((inhibit-read-only t)) - (delete-region (point-min) (point-max)) - (insert "Starting macro expansion stepper... please wait...\n")) - (racket--cmd/async racket--stepper-repl-session-id - `(macro-stepper (,which . ,(if (eq which 'file) - (racket-file-name-front-to-back str) - str)) - ,(if no-hiding - 'disable - racket-expand-hiding)) - #'racket-stepper--insert))) + (unless (or (not expression-str) + racket--stepper-repl-session-id) + (error "Expression expansion only works when the edit buffer has a REPL buffer, and, you should racket-run first")) + (let ((path (racket-file-name-front-to-back (racket--buffer-file-name)))) + ;; Create buffer if necessary + (let ((name (racket--stepper-buffer-name))) + (unless (get-buffer name) + (with-current-buffer (get-buffer-create name) + (racket-stepper-mode))) + ;; Give it a window if necessary + (unless (get-buffer-window name) + (pop-to-buffer (get-buffer name))) + ;; Select the stepper window and insert + (select-window (get-buffer-window name)) + (let ((inhibit-read-only t)) + (delete-region (point-min) (point-max)) + (insert "Starting macro expansion stepper... please wait...\n")) + (racket--cmd/async racket--stepper-repl-session-id + `(macro-stepper ,path + ,expression-str + ,(if no-hiding + 'disable + racket-expand-hiding)) + #'racket-stepper--insert)))) (defun racket-stepper--insert (nothing-or-steps) (if (eq nothing-or-steps 'nothing) diff --git a/racket/command-server.rkt b/racket/command-server.rkt index dce5dc0e..76e9a222 100644 --- a/racket/command-server.rkt +++ b/racket/command-server.rkt @@ -136,7 +136,7 @@ [`(no-op) #t] [`(logger ,v) (channel-put logger-command-channel v)] [`(check-syntax ,path-str ,code) (check-syntax path-str code)] - [`(macro-stepper ,str ,into-base?) (macro-stepper str into-base?)] + [`(macro-stepper ,path ,str ,pol) (macro-stepper path str pol)] [`(macro-stepper/next ,what) (macro-stepper/next what)] [`(module-names) (module-names)] [`(requires/tidy ,reqs) (requires/tidy reqs)] diff --git a/racket/commands/macro.rkt b/racket/commands/macro.rkt index 43bb60c1..1aa86e43 100644 --- a/racket/commands/macro.rkt +++ b/racket/commands/macro.rkt @@ -29,50 +29,36 @@ (define step-proc #f) (define (nothing-step-proc _) 'nothing) -(define/contract (make-expr-stepper str) - (-> string? step-proc/c) - (unless (current-session-id) - (error 'make-expr-stepper "Does not work without a running REPL")) - (define step-num #f) - (define last-stx (string->namespace-syntax str)) - (define/contract (step what) step-proc/c - (cond [(not step-num) - (set! step-num 0) - (list (cons 'original - (pretty-format-syntax last-stx)))] - [else - (define result - (let loop () - (define this-stx (expand-once last-stx)) - (cond [(equal? (syntax->datum last-stx) - (syntax->datum this-stx)) - (cond [(eq? what 'all) - (list (cons 'final - (pretty-format-syntax this-stx)))] - [else (list)])] - [else - (set! step-num (add1 step-num)) - (define step - (cons (~a step-num ": expand-once") - (diff-text (pretty-format-syntax last-stx) - (pretty-format-syntax this-stx) - #:unified 3))) - (set! last-stx this-stx) - (cond [(eq? what 'all) (cons step (loop))] - [else (list step)])]))) - (match result - [(list) (list (cons 'final - (pretty-format-syntax last-stx)))] - [v v])])) - step) +(define/contract (macro-stepper path expression-str hiding-policy) + (-> (and/c path-string? complete-path?) any/c any/c + (list/c step/c)) + (define-values (stx ns) + (cond + [(string? expression-str) + (unless (current-session-id) + (error 'macro-stepper "Does not work without a running REPL")) + (values (string->namespace-syntax expression-str) + (current-namespace))] + [else + (values (file->syntax path) + (make-base-namespace))])) + (set! step-proc + (make-stepper path stx ns hiding-policy)) + (macro-stepper/next 'next)) -(define/contract (make-file-stepper path elisp-policy) - (-> (and/c path-string? absolute-path?) any/c step-proc/c) - (assert-file-stepper-works) - (define stx (file->syntax path)) +(define/contract (macro-stepper/next what) step-proc/c + (define v (step-proc what)) + (match v + [(list (cons 'final _)) (set! step-proc nothing-step-proc)] + [_ (void)]) + v) + +(define/contract (make-stepper path stx ns elisp-hiding-policy) + (-> (and/c path-string? complete-path?) syntax? namespace? any/c + step-proc/c) + (assert-macro-debugger-stepper-works) (define dir (path-only path)) - (define ns (make-base-namespace)) - (define policy (elisp-policy->policy elisp-policy)) + (define policy (elisp-policy->policy elisp-hiding-policy)) (define predicate (policy->predicate policy)) (define raw-step (parameterize ([current-load-relative-directory dir] [current-namespace ns]) @@ -108,6 +94,7 @@ (list (cons 'final step-last-after))])])) step) + (define (elisp-policy->policy e) ;; See macro-debugger/model/hiding-policies.rkt): ;; @@ -141,28 +128,12 @@ (pretty-format #:mode 'write before) (pretty-format #:mode 'write after))])) -(define (assert-file-stepper-works) +(define (assert-macro-debugger-stepper-works) (define step (stepper-text #'(module example racket/base 42))) (unless (step 'next) (error 'macro-debugger/stepper-text "does not work in your version of Racket.\nPlease try an older or newer version."))) -(define/contract (macro-stepper what policy) - (-> (or/c (cons/c 'expr string?) (cons/c 'file path-string?)) any/c - (list/c step/c)) - (set! step-proc - (match what - [(cons 'expr str) (make-expr-stepper str)] - [(cons 'file path) (make-file-stepper path policy)])) - (macro-stepper/next 'next)) - -(define/contract (macro-stepper/next what) step-proc/c - (define v (step-proc what)) - (match v - [(list (cons 'final _)) (set! step-proc nothing-step-proc)] - [_ (void)]) - v) - (define (diff-text before-text after-text #:unified [-U 3]) (define template "racket-mode-syntax-diff-~a") (define (make-temporary-file-with-text str) diff --git a/test/racket-tests.el b/test/racket-tests.el index f302bc16..29cb40a9 100644 --- a/test/racket-tests.el +++ b/test/racket-tests.el @@ -393,7 +393,7 @@ c.rkt. Visit each file, racket-run, and check as expected." (call-process racket-program nil t nil "--version") (buffer-substring-no-properties (point-min) (point-max))))) -(defun racket-tests/expected-result-for-expand-p (result) +(defun racket-tests/expected-result-for-expand-file-p (result) "Test expected to fail because macro-debugger broken in Racket 7.6. For use with :expected-result '(satisfies PRED). This matters because ert-deftest is a macro evaluated at compile time, and we @@ -402,6 +402,18 @@ want to use the value of `racket-program' at run time." (ert-test-failed-p result) (ert-test-passed-p result))) +(defun racket-tests/racket-8.11.1-or-newer-p () + (zerop + (call-process + racket-program nil nil nil + "-e" "(require version/utils) (unless (version ")))) (goto-char (point-max)) ;after the cond expression - (racket-expand-last-sexp) + (racket-expand-last-sexp t) (set-buffer "*Racket Stepper *") (should (eq major-mode 'racket-stepper-mode)) (should (equal header-line-format "Press RET to step. C-u RET to step all. C-h m to see help.")) - (racket-tests/should-eventually - (faceup-test-font-lock-buffer nil racket-tests/expand-expression-0)) - (racket-tests/press "RET") - (racket-tests/should-eventually - (faceup-test-font-lock-buffer nil racket-tests/expand-expression-1)) - (racket-tests/press "RET") (racket-tests/should-eventually - (faceup-test-font-lock-buffer nil racket-tests/expand-expression-2)) - (racket-tests/press "RET") - (racket-tests/should-eventually - (faceup-test-font-lock-buffer nil racket-tests/expand-expression-3)) - (racket-tests/press "RET") + (faceup-test-font-lock-buffer nil racket-tests/expand-expression-original)) + + (racket-tests/press "C-u RET") (racket-tests/should-eventually - (faceup-test-font-lock-buffer nil racket-tests/expand-expression-4)) + (faceup-test-font-lock-buffer nil racket-tests/expand-expression-final)) (quit-window) (with-racket-repl-buffer