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
|
#lang at-exp racket/base
(require racket/match
racket/format)
(provide (rename-out [command-channel logger-command-channel]
[notify-channel logger-notify-channel]))
;; "On start-up, Racket creates an initial logger that is used to
;; record events from the core run-time system. For example, an 'debug
;; event is reported for each garbage collection (see Garbage
;; Collection)." Use that; don't create new one. See issue #325.
(define global-logger (current-logger))
(define command-channel (make-channel))
(define notify-channel (make-channel))
(define (logger-thread)
(let wait ([receiver (make-receiver '((racket-mode . debug)
(* . warning)))])
(sync
(handle-evt command-channel
(λ (v)
(wait (make-receiver v))))
(handle-evt receiver
(match-lambda
[(vector level message _v topic)
(channel-put notify-channel
`(logger
,(~a (label level) " "
(ensure-topic-in-message topic message)
"\n")))
(wait receiver)])))))
;; Go ahead and start this early so we can see our own
;; log-racket-mode-xxx ouput in the front end.
(void (thread logger-thread))
(define (ensure-topic-in-message topic message)
(match message
[(pregexp (format "^~a: " (regexp-quote (~a topic))))
message]
[message-without-topic
(format "~a: ~a" (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]}]))
(define (make-receiver alist)
(apply make-log-receiver (list* global-logger
(alist->spec alist))))
;; Convert from ([logger . level] ...) alist to the format used by
;; make-log-receiver: (level logger ... ... default-level). In the
;; alist, treat the logger '* as the default level.
(define (alist->spec xs) ;(Listof (Pairof Symbol Symbol)) -> (Listof Symbol)
(for/fold ([spec '()])
([x (in-list xs)])
(append spec
(match x
[(cons '* level) (list level)]
[(cons logger level) (list level logger)]))))
|
