branch: elpa/racket-mode
commit 1ec8ac5341ba9f9b70de02a8397fa02297594c16
Author: Greg Hendershott <g...@greghendershott.com>
Commit: Greg Hendershott <g...@greghendershott.com>
Don't font-lock logger output
Commit a23104e set font-lock-keywords-only. On reflection, it doesn't
make much sense to use font-lock at all in the logger output buffer.
Instead the back end could supply structured data (as opposed to a
string), and was can apply face properties directly when inserting.
This should be faster.
Similarly, insert a text property to let us find the start of each
item, and update the previous/next item commands to use that instead
of a regexp search.
Note: This uses the compat package to supply text-property-search
functions on older versions of Emacs.
---
racket-logger.el | 105 ++++++++++++++++++++++++------------------------------
racket/logger.rkt | 40 +++++++++------------
2 files changed, 63 insertions(+), 82 deletions(-)
diff --git a/racket-logger.el b/racket-logger.el
index d9ad9fc7d2..5814c4431c 100644
--- a/racket-logger.el
+++ b/racket-logger.el
@@ -8,6 +8,7 @@
;; SPDX-License-Identifier: GPL-3.0-or-later
+(require 'compat) ;for text-property-search-{forward backward}
(require 'easymenu)
(require 'rx)
(require 'racket-custom)
@@ -31,32 +32,6 @@
"---"
["Clear" racket-logger-clear]))
-(defconst racket-logger-font-lock-keywords
- (eval-when-compile
- `((,#'racket--font-lock-config . racket-logger-config-face)
- (,(rx bol "[ fatal]") . racket-logger-fatal-face)
- (,(rx bol "[ error]") . racket-logger-error-face)
- (,(rx bol "[warning]") . racket-logger-warning-face)
- (,(rx bol "[ info]") . racket-logger-info-face)
- (,(rx bol "[ debug]") . racket-logger-debug-face)
- (,(rx bol ?\[ (+? anything) ?\] space
- (group (+? anything) ?:) space)
- 1 racket-logger-topic-face))))
-
-(defconst racket--logger-print-config-prefix
- "racket-logger-config:\n")
-
-(defun racket--font-lock-config (limit)
- "Handle multi-line font-lock of the configuration info."
- (ignore-errors
- (when (re-search-forward (concat "^" racket--logger-print-config-prefix)
limit t)
- (let ((md (match-data)))
- (goto-char (match-end 0))
- (forward-sexp 1)
- (setf (elt md 1) (point)) ;; set (match-end 0)
- (set-match-data md)
- t))))
-
(define-derived-mode racket-logger-mode special-mode "Racket-Logger"
"Major mode for Racket logger output.
\\<racket-logger-mode-map>
@@ -70,9 +45,7 @@ For more information see:
\\{racket-logger-mode-map}
"
- (setq-local font-lock-defaults
- (list racket-logger-font-lock-keywords
- t)) ;keywords-only #751
+ (setq-local font-lock-defaults (list nil t)) ;no font lock
(setq-local truncate-lines t)
(setq-local buffer-undo-list t) ;disable undo
(setq-local window-point-insertion-type t))
@@ -90,7 +63,7 @@ For more information see:
(racket--logger-activate-config)))
(get-buffer name)))
-(defun racket--logger-on-notify (back-end-name str)
+(defun racket--logger-on-notify (back-end-name v)
"This is called from `racket--cmd-dispatch-response'.
As a result, we might create this buffer before the user does a
@@ -98,13 +71,29 @@ As a result, we might create this buffer before the user
does a
(when noninteractive ;emacs --batch
(princ (format "{logger %s}: %s"
(racket-back-end-name)
- str)))
+ v)))
(with-current-buffer (racket--logger-get-buffer-create back-end-name)
- (let* ((inhibit-read-only t)
- (original-point (point))
- (point-was-at-end-p (equal original-point (point-max))))
+ (pcase-let* ((`(,level ,topic ,message) v)
+ (`(,level-str . ,level-face)
+ (pcase level
+ ('fatal (cons "[ fatal]" racket-logger-fatal-face))
+ ('error (cons "[ error]" racket-logger-error-face))
+ ('warning (cons "[warning]" racket-logger-warning-face))
+ ('info (cons "[ info]" racket-logger-info-face))
+ ('debug (cons "[ debug]" racket-logger-debug-face))))
+ (inhibit-read-only t)
+ (original-point (point))
+ (point-was-at-end-p (equal original-point (point-max))))
(goto-char (point-max))
- (insert str)
+ (insert (propertize level-str
+ 'face level-face
+ 'racket-logger-item-level t)
+ " "
+ (propertize (symbol-name topic)
+ 'face racket-logger-topic-face)
+ ": "
+ message
+ "\n")
(unless point-was-at-end-p
(goto-char original-point)))))
@@ -115,9 +104,9 @@ As a result, we might create this buffer before the user
does a
(with-current-buffer (racket--logger-get-buffer-create)
(let ((inhibit-read-only t))
(goto-char (point-max))
- (insert (propertize (concat racket--logger-print-config-prefix
+ (insert (propertize (concat "racket-logger-config:\n"
(pp-to-string racket-logger-config))
- 'font-lock-multiline t))
+ 'face racket-logger-config-face))
(goto-char (point-max)))))
(defun racket--logger-set (topic level)
@@ -168,31 +157,31 @@ As a result, we might create this buffer before the user
does a
(delete-region (point-min) (point-max)))
(racket--logger-activate-config))))
-(defconst racket--logger-item-rx
- (rx bol ?\[ (0+ space) (or "fatal" "error" "warning" "info" "debug") ?\]
space))
-
(defun racket-logger-next-item (&optional count)
- "Move point N items forward.
-
-An \"item\" is a line starting with a log level in brackets.
-
-Interactively, N is the numeric prefix argument.
-If N is omitted or nil, move point 1 item forward."
- (interactive "P")
- (forward-char 1)
- (if (re-search-forward racket--logger-item-rx nil t count)
- (beginning-of-line)
- (backward-char 1)))
+ "Move point forward COUNT logger output items.
+
+Interactively, COUNT is the numeric prefix argument. If COUNT is
+omitted or nil, move point 1 item forward."
+ (interactive "p")
+ (let* ((count (or count 1))
+ (step (if (< 0 count) -1 1))
+ (search (if (< 0 count)
+ #'text-property-search-forward
+ #'text-property-search-backward)))
+ (while (not (zerop count))
+ (let ((match (funcall search 'racket-logger-item-level t t t)))
+ (if (not match)
+ (setq count 0)
+ (goto-char (prop-match-beginning match))
+ (setq count (+ count step)))))))
(defun racket-logger-previous-item (&optional count)
- "Move point N items backward.
-
-An \"item\" is a line starting with a log level in brackets.
+ "Move point backward COUNT logger output items.
-Interactively, N is the numeric prefix argument.
-If N is omitted or nil, move point 1 item backward."
- (interactive "P")
- (re-search-backward racket--logger-item-rx nil t count))
+Interactively, COUNT is the numeric prefix argument. If COUNT is
+omitted or nil, move point 1 item backward."
+ (interactive "p")
+ (racket-logger-next-item (if count (- count) -1)))
(defun racket-logger-topic-level ()
"Set or unset the level for a topic.
diff --git a/racket/logger.rkt b/racket/logger.rkt
index b7ee9d0c37..e979b7791c 100644
--- a/racket/logger.rkt
+++ b/racket/logger.rkt
@@ -1,4 +1,4 @@
-;; Copyright (c) 2013-2022 by Greg Hendershott.
+;; Copyright (c) 2013-2022, 2025 by Greg Hendershott.
;; SPDX-License-Identifier: GPL-3.0-or-later
#lang at-exp racket/base
@@ -37,37 +37,29 @@
[(vector level message _v topic)
(channel-put notify-channel
`(logger
- ,(~a (label level) " "
- (ensure-topic-in-message topic message)
- "\n")))
+ ,(cons level
+ (topic+message topic message))))
(wait receiver)])))))
(void (thread racket-mode-log-receiver-thread))
-(define (ensure-topic-in-message topic message)
+(define (topic+message topic message)
(match message
- [(pregexp (format "^~a: " (regexp-quote (~a topic))))
- message]
+ [(pregexp (format "^~a: (.*)$" (regexp-quote (~a topic)))
+ (list _ message))
+ (list topic
+ message)]
[message-without-topic
- (format "~a: ~a" (or topic "*") message-without-topic)]))
+ (list (or topic '*)
+ message-without-topic)]))
(module+ test
(require rackunit)
- (check-equal? (ensure-topic-in-message 'topic "topic: message")
- "topic: message")
- (check-equal? (ensure-topic-in-message 'topic "message")
- "topic: message")
- (check-equal? (ensure-topic-in-message #f "message")
- "*: message"))
-
-(define (label level)
- ;; justify
- (case level
- [(debug) "[ debug]"]
- [(info) "[ info]"]
- [(warning) "[warning]"]
- [(error) "[ error]"]
- [(fatal) "[ fatal]"]
- [else @~a{[level]}]))
+ (check-equal? (topic+message 'topic "message")
+ (list 'topic "message"))
+ (check-equal? (topic+message 'topic "topic: message")
+ (list 'topic "message"))
+ (check-equal? (topic+message #f "message")
+ (list '* "message")))
(define (make-receiver alist)
(apply make-log-receiver (list* global-logger
