1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
|
;;; racket-logger.el -*- lexical-binding: t; -*-
;; Copyright (c) 2013-2025 by Greg Hendershott.
;; Portions Copyright (C) 1985-1986, 1999-2013 Free Software Foundation, Inc.
;; Author: Greg Hendershott
;; URL: https://github.com/greghendershott/racket-mode
;; SPDX-License-Identifier: GPL-3.0-or-later
(require 'compat) ;for text-property-search-{forward backward}
(require 'easymenu)
(require 'rx)
(require 'racket-custom)
(require 'racket-repl)
(require 'racket-back-end)
;; Need to define this before racket-logger-mode
(defvar racket-logger-mode-map
(racket--easy-keymap-define
'(("l" racket-logger-topic-level)
("w" toggle-truncate-lines)
("n" racket-logger-next-item)
("p" racket-logger-previous-item)
("g" racket-logger-clear))))
(easy-menu-define racket-logger-mode-menu racket-logger-mode-map
"Menu for Racket logger mode."
'("Racket-Logger"
["Configure Topic and Level" racket-logger-topic-level]
["Toggle Truncate Lines" toggle-truncate-lines]
"---"
["Clear" racket-logger-clear]))
(define-derived-mode racket-logger-mode special-mode "Racket-Logger"
"Major mode for Racket logger output.
\\<racket-logger-mode-map>
The customization variable `racket-logger-config' determines the
levels for topics. During a session you may change topic levels
using `racket-logger-topic-level'.
For more information see:
<https://docs.racket-lang.org/reference/logging.html>
\\{racket-logger-mode-map}
"
(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))
(defun racket--logger-buffer-name (&optional back-end-name)
(format "*Racket Logger <%s>*" (or back-end-name
(racket-back-end-name))))
(defun racket--logger-get-buffer-create (&optional back-end-name)
"Create buffer if necessary. Do not display or select it."
(let ((name (racket--logger-buffer-name back-end-name)))
(unless (get-buffer name)
(with-current-buffer (get-buffer-create name)
(racket-logger-mode)
(racket--logger-activate-config)))
(get-buffer name)))
(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
`racket-logger-mode' command."
(when noninteractive ;emacs --batch
(princ (format "{logger %s}: %s"
(racket-back-end-name)
v)))
(with-current-buffer (racket--logger-get-buffer-create back-end-name)
(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 (propertize level-str
'font-lock-face level-face
'racket-logger-item-level t)
" "
(propertize (symbol-name topic)
'font-lock-face racket-logger-topic-face)
": "
message
"\n")
(unless point-was-at-end-p
(goto-char original-point)))))
(defun racket--logger-activate-config ()
"Send config to logger and display it in the buffer."
(racket--cmd/async nil
`(logger ,racket-logger-config))
(with-current-buffer (racket--logger-get-buffer-create)
(let ((inhibit-read-only t))
(goto-char (point-max))
(insert (propertize (concat "racket-logger-config:\n"
(pp-to-string racket-logger-config))
'font-lock-face racket-logger-config-face))
(goto-char (point-max)))))
(defun racket--logger-set (topic level)
(unless (symbolp topic) (error "TOPIC must be symbolp"))
(unless (symbolp level) (error "LEVEL must be symbolp"))
(pcase (assq topic racket-logger-config)
(`() (add-to-list 'racket-logger-config (cons topic level)))
(v (setcdr v level)))
(racket--logger-activate-config))
(defun racket--logger-unset (topic)
(unless (symbolp topic) (error "TOPIC must be symbolp"))
(when (eq topic '*)
(user-error "Cannot unset the level for the '* topic"))
(setq racket-logger-config
(assq-delete-all topic racket-logger-config))
(racket--logger-activate-config))
(defun racket--logger-topics ()
"Effectively (sort (dict-keys racket-logger-config))."
(sort (mapcar (lambda (x) (format "%s" (car x)))
racket-logger-config)
#'string<))
(defun racket--logger-topic-level (topic not-found)
"Effectively (dict-ref racket-logger-config topic not-found)."
(or (cdr (assq topic racket-logger-config))
not-found))
;;; commands
(defun racket-logger ()
"Create the `racket-logger-mode' buffer."
(interactive)
(racket--logger-get-buffer-create)
;; Give it a window if necessary
(unless (get-buffer-window (racket--logger-buffer-name))
(display-buffer (get-buffer (racket--logger-buffer-name))))
;; Select the window
(select-window (get-buffer-window (racket--logger-buffer-name))))
(defun racket-logger-clear ()
"Clear the buffer and reconnect."
(interactive)
(when (eq major-mode 'racket-logger-mode)
(when (y-or-n-p "Clear buffer? ")
(let ((inhibit-read-only t))
(delete-region (point-min) (point-max)))
(racket--logger-activate-config))))
(defun racket-logger-next-item (&optional count)
"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 backward COUNT logger output items.
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.
The topic labeled \"*\" is the level to use for all topics not
specifically assigned a level.
The level choice \"*\" means the topic will no longer have its
own level, therefore will follow the level specified for the
\"*\" topic."
(interactive)
(let* ((topic (completing-read
"Topic: "
(racket--logger-topics)))
(topic (pcase topic
("" "*")
(v v)))
(topic (intern topic))
(levels (list "fatal" "error" "warning" "info" "debug"))
(levels (if (eq topic '*) levels (cons "*" levels)))
(level (completing-read
(format "Level for topic `%s': " topic)
levels
nil t nil nil
(format "%s" (racket--logger-topic-level topic "*"))))
(level (pcase level
("" nil)
("*" nil)
(v (intern v)))))
(if level
(racket--logger-set topic level)
(racket--logger-unset topic))))
(provide 'racket-logger)
;;; racket-logger.el ends here
|
