[nongnu] elpa/racket-mode 22dc95ced1 3/3: Improve racket-repl after-change behavior; fixes #731

[ELPA Syncer]

branch: elpa/racket-mode
commit 22dc95ced15a1c153386bc9ec12635b3b0225113
Author: Greg Hendershott <git@greghendershott.com>
Commit: Greg Hendershott <git@greghendershott.com>

    Improve racket-repl after-change behavior; fixes #731
    
    Reduce the number and extent of calls to after-change-functions.
    
    - Use inhibit-modification-hooks when using remove-text-properties on
    rear-nonsticky text properties for the entire buffer. Our back end
    hash-lang object doesn't need this huge, meaningless change. Nor do
    things like jit-lock-after change. This mitigates the proximate cause
    of #731.
    
    - Consolidate newline+insert into insert (the "fresh line" stuff).
    
    - Non-substantive: Rewrite cl-case as pcase.
    
    Also, in racket-hash-lang.el, some non-substantive changes:
    
    - Fix prose in doc string for racket--hash-lang-repl-buffer-string.
    
    - Rename racket--hash-lang-after-change-hook to
    racket--hash-lang-after-change -- for brevity, but also because
    technically it's not a value for a hook, it's a value for the variable
    `after-change-functions`.
---
 racket-hash-lang.el |  35 +++++++++--------
 racket-repl.el      | 111 +++++++++++++++++++++++++++-------------------------
 2 files changed, 76 insertions(+), 70 deletions(-)

diff --git a/racket-hash-lang.el b/racket-hash-lang.el
index 35c9fb1e44..125a68a316 100644
--- a/racket-hash-lang.el
+++ b/racket-hash-lang.el
@@ -297,7 +297,7 @@ A discussion of the information provided by a Racket 
language:
        (setq-local racket--hash-lang-id maybe-id)
        ;; These need non-nil `racket--hash-lang-id':
        (setq-local font-lock-fontify-region-function 
#'racket--hash-lang-fontify-region)
-       (add-hook 'after-change-functions #'racket--hash-lang-after-change-hook 
t t)
+       (add-hook 'after-change-functions #'racket--hash-lang-after-change t t)
        (add-hook 'kill-buffer-hook #'racket--hash-lang-delete t t)
        (add-hook 'change-major-mode-hook #'racket--hash-lang-delete t t)
        (setq-local buffer-read-only nil))
@@ -342,8 +342,8 @@ live back end, downgrade them all to `prog-mode'."
 ;;; Updates: Front end --> back end
 
 (defun racket--hash-lang-repl-buffer-string (beg end)
-  "Like `buffer-substring-no-properties' treat as whitespace,
-preserving only line breaks for indentation, everything that is
+  "Like `buffer-substring-no-properties' but treat as whitespace --
+preserving only line breaks for indentation -- everything that is
 not a value output since the last run, or input after the last
 live prompt."
   (let ((result-str ""))
@@ -362,21 +362,22 @@ live prompt."
                                               raw)))))))
     result-str))
 
-(defun racket--hash-lang-after-change-hook (beg end len)
-  ;;;(message "racket--hash-lang-after-change-hook %s %s %s" beg end len)
+(defun racket--hash-lang-after-change (beg end len)
+  ;;;(message "racket--hash-lang-after-change %s %s %s" beg end len)
   ;; This might be called as frequently as once per single changed
   ;; character.
   (when racket--hash-lang-id
-    (racket--cmd/async
-     nil
-     `(hash-lang update
-                 ,racket--hash-lang-id
-                 ,(cl-incf racket--hash-lang-generation)
-                 ,beg
-                 ,len
-                 ,(if (eq major-mode 'racket-repl-mode)
-                      (racket--hash-lang-repl-buffer-string beg end)
-                    (buffer-substring-no-properties beg end))))))
+    (let ((str (if (eq major-mode 'racket-repl-mode)
+                   (racket--hash-lang-repl-buffer-string beg end)
+                 (buffer-substring-no-properties beg end))))
+      (racket--cmd/async
+       nil
+       `(hash-lang update
+                   ,racket--hash-lang-id
+                   ,(cl-incf racket--hash-lang-generation)
+                   ,beg
+                   ,len
+                   ,str)))))
 
 ;;; Notifications: Front end <-- back end
 
@@ -913,8 +914,8 @@ rhombus\"."
                   (with-current-buffer edit-buffer forward-sexp-function))
       (racket-hash-lang-repl-mode (if hash-lang-p 1 -1)) ;keybindings
       (if hash-lang-p
-          (add-hook 'after-change-functions 
#'racket--hash-lang-after-change-hook t t)
-        (remove-hook 'after-change-functions  
#'racket--hash-lang-after-change-hook t))
+          (add-hook 'after-change-functions #'racket--hash-lang-after-change t 
t)
+        (remove-hook 'after-change-functions  #'racket--hash-lang-after-change 
t))
       (setq-local racket-repl-submit-function
                   (if hash-lang-p #'racket-hash-lang-submit nil)))))
 
diff --git a/racket-repl.el b/racket-repl.el
index 878f475318..80b5825936 100644
--- a/racket-repl.el
+++ b/racket-repl.el
@@ -239,79 +239,84 @@ live prompt this marker will be at `point-max'.")
 (defun racket--repl-insert-output (kind value)
   (let ((moving (= (point) racket--repl-output-mark))
         (inhibit-read-only t))
+    ;; Previous chunks of output may have ended with a rear-nonsticky
+    ;; property to allow input to follow. Now that we're adding more
+    ;; output, remove that property so there are no read/write "seams"
+    ;; between chunks.
+    (let ((inhibit-modification-hooks t)) ;avoid after-change: #731
+      (remove-text-properties (point-min)
+                              (point-max)
+                              '(rear-nonsticky nil)))
     (save-excursion
       (goto-char racket--repl-output-mark)
       (let ((pt (point)))
-        ;; Previous chunks of output may have ended with a
-        ;; rear-nonsticky property to allow input to follow. Now that
-        ;; we're adding more output, remove that property so there are
-        ;; no read/write "seams" between chunks.
-        (remove-text-properties (point-min) (point) '(rear-nonsticky nil))
         (cl-flet*
-            ((fresh-line () (unless (bolp) (newline)))
-             (faced (str face) (propertize str 'font-lock-face face))
-             (insert-faced (str face) (insert (faced str face)))
-             (insert-filtered (str face) (insert (racket--repl-filter-output
-                                                  (faced str face)))))
-          (cl-case kind
-            ((run)
+            ((faced (str face)
+               (propertize str 'font-lock-face face))
+             (insert-faced (str face &optional no-fresh-line)
+               (let ((str (faced str face)))
+                 (insert (if (or no-fresh-line (bolp))
+                             str
+                           (concat "\n" str)))))
+             (insert-filtered (str face)
+               (insert (racket--repl-filter-output
+                        (faced str face)))))
+          (pcase kind
+            ('run
              (racket--repl-delete-prompt-mark 'abandon)
              (unless (equal value "")
-               (fresh-line)
                (insert-faced (format "————— run %s —————\n" value) 
'racket-repl-message)))
-            ((prompt)
+            ('prompt
              (racket--repl-make-prompt-mark value))
-            ((message)
-             (fresh-line)
+            ('message
              (insert-faced value 'racket-repl-message)
              (unless (bolp) (newline)))
-            ((exit)
+            ('exit
              (racket--repl-delete-prompt-mark 'abandon)
-             (fresh-line)
              (insert-faced value 'racket-repl-message)
              (unless (bolp) (newline))
-             (setq moving t) ;leave point after, for tests
+             (setq moving t)        ;leave point after, for tests
              (setq racket--repl-session-id nil))
-            ((value)
-             (insert-faced value 'racket-repl-value))
-            ((value-special)
+            ('value
+             (insert-faced value 'racket-repl-value t))
+            ('value-special
              (pcase-let ((`(image . ,file) value))
                (racket--repl-insert-image file)))
-            ((error)
+            ('error
              (pcase value
                (`(,msg ,srclocs (,context-kind . ,context-names-and-locs))
-                (fresh-line)
-                (insert-faced msg 'racket-repl-error-message)
-                (newline)
-                ;; Heuristic: When something supplies exn-srclocs,
-                ;; show those only. Otherwise show context if any.
-                ;; This seems to work well for most runtime
-                ;; exceptions, as well as for rackunit test failures
-                ;; (where the srcloc suffices and the context esp
-                ;; w/errortrace is useless noise).
-                (cond (srclocs
-                       (dolist (loc srclocs)
-                         (insert " ")
-                         (insert (racket--format-error-location loc))
-                         (newline)))
-                      (context-names-and-locs
-                       (insert-faced (format "Context (%s):" context-kind)
-                                     'racket-repl-error-message)
-                       (newline)
-                       (dolist (v context-names-and-locs)
-                         (pcase-let ((`(,name . ,loc) v))
-                           (insert " ")
-                           (insert (racket--format-error-location loc))
-                           (insert " ")
-                           (when name
-                             (insert-faced name 'racket-repl-error-label)))
-                         (newline)))))))
-            ((stdout)
+                (combine-after-change-calls
+                  (insert-faced msg 'racket-repl-error-message)
+                  (newline)
+                  ;; Heuristic: When something supplies exn-srclocs,
+                  ;; show those only. Otherwise show context if any.
+                  ;; This seems to work well for most runtime
+                  ;; exceptions, as well as for rackunit test failures
+                  ;; (where the srcloc suffices and the context esp
+                  ;; w/errortrace is useless noise).
+                  (cond
+                   (srclocs
+                    (dolist (loc srclocs)
+                      (insert " ")
+                      (insert (racket--format-error-location loc))
+                      (newline)))
+                   (context-names-and-locs
+                    (insert-faced (format "Context (%s):" context-kind)
+                                  'racket-repl-error-message)
+                    (newline)
+                    (dolist (v context-names-and-locs)
+                      (pcase-let ((`(,name . ,loc) v))
+                        (insert " ")
+                        (insert (racket--format-error-location loc))
+                        (insert " ")
+                        (when name
+                          (insert-faced name 'racket-repl-error-label t)))
+                      (newline))))))))
+            ('stdout
              (insert-filtered value 'racket-repl-stdout))
-            ((stderr)
+            ('stderr
              (insert-filtered value 'racket-repl-stderr))
-            (otherwise
-             (fresh-line)
+            (_
              (insert-faced value 'racket-repl-message))))
         (unless (eq kind 'prompt)
           (add-text-properties pt (point)