|
| 1 | +;; SPDX-License-Identifier: MIT |
| 2 | +;; Copyright (c) 2026 jrtxio <jirentianxiang1024@gmail.com> |
| 3 | +;; See LICENSE at the repository root for full terms. |
| 4 | + |
| 5 | +#lang racket/base |
| 6 | + |
| 7 | +(require racket/class |
| 8 | + racket/gui/base |
| 9 | + racket/string) |
| 10 | + |
| 11 | +(provide log-view%) |
| 12 | + |
| 13 | +;; log-view% — a scrolling, read-only, monospace log/console output. |
| 14 | +;; |
| 15 | +;; Why this exists: building this from core `editor-canvas%` + `text%` is where |
| 16 | +;; everyone gets stuck — the canvas won't stretch (parent container trap), it |
| 17 | +;; does not auto-scroll to the newest line, making it read-only also blocks |
| 18 | +;; programmatic inserts, and long-running logs grow without bound. `log-view%` |
| 19 | +;; handles all of it: it stretches to fill its parent by default, appends lines |
| 20 | +;; and auto-scrolls to the bottom, stays read-only to the user while still |
| 21 | +;; accepting programmatic appends, and trims old lines past `max-lines`. |
| 22 | +;; |
| 23 | +;; (define log (new log-view% [parent f])) |
| 24 | +;; (send log append-line "[boot] ready") |
| 25 | +(define log-view% |
| 26 | + (class editor-canvas% |
| 27 | + (init-field [max-lines 10000] |
| 28 | + [monospace? #t] |
| 29 | + [wrap? #t] |
| 30 | + [read-only? #t]) |
| 31 | + |
| 32 | + ;; Build the editor first (no `this` needed), then hand it to the canvas. |
| 33 | + (define editor (new text%)) |
| 34 | + (send editor auto-wrap wrap?) |
| 35 | + |
| 36 | + (super-new |
| 37 | + [editor editor] |
| 38 | + [style (if wrap? '(no-hscroll) '())]) |
| 39 | + ;; editor-canvas% defaults to stretchable in both dimensions, so log-view% |
| 40 | + ;; fills its parent automatically. Callers can still override min-width, |
| 41 | + ;; min-height, stretchable-*, etc. via the usual init fields. |
| 42 | + |
| 43 | + (define mono-delta |
| 44 | + (and monospace? (make-object style-delta% 'change-family 'modern))) |
| 45 | + |
| 46 | + ;; A read-only lock also blocks programmatic edits, so toggle it around |
| 47 | + ;; each mutation. |
| 48 | + (when read-only? (send editor lock #t)) |
| 49 | + (define (unlock!) (when read-only? (send editor lock #f))) |
| 50 | + (define (relock!) (when read-only? (send editor lock #t))) |
| 51 | + |
| 52 | + ;; Append a line of text (a trailing newline is ensured) and scroll to it. |
| 53 | + ;; Non-strings are formatted with ~a. |
| 54 | + (define/public (append-line line) |
| 55 | + (define s (if (string? line) line (format "~a" line))) |
| 56 | + (define text (if (string-suffix? s "\n") s (string-append s "\n"))) |
| 57 | + (unlock!) |
| 58 | + (define start (send editor last-position)) |
| 59 | + (send editor insert text start) |
| 60 | + (when mono-delta |
| 61 | + (send editor change-style mono-delta start (send editor last-position))) |
| 62 | + (trim!) |
| 63 | + (send editor scroll-to-position (send editor last-position)) |
| 64 | + (relock!)) |
| 65 | + |
| 66 | + ;; Drop the oldest lines once the buffer exceeds max-lines. |
| 67 | + (define (trim!) |
| 68 | + (define nl (send editor last-line)) |
| 69 | + (when (> nl max-lines) |
| 70 | + (send editor delete 0 (send editor line-start-position (- nl max-lines))))) |
| 71 | + |
| 72 | + ;; Erase the whole log. |
| 73 | + (define/public (clear) |
| 74 | + (unlock!) |
| 75 | + (send editor erase) |
| 76 | + (relock!)) |
| 77 | + |
| 78 | + ;; All log text as a string. |
| 79 | + (define/public (get-text) |
| 80 | + (send editor get-text)) |
| 81 | + |
| 82 | + ;; Scroll so the most recent line is visible. |
| 83 | + (define/public (scroll-to-bottom) |
| 84 | + (send editor scroll-to-position (send editor last-position))))) |
0 commit comments