Update ,log to handle multiple loggers.

pkgs/xrepl-pkgs/xrepl-lib/xrepl/xrepl.rkt

@@ -1165,39 +1165,75 @@
 ;; ----------------------------------------------------------------------------
 ;; dynamic log output control
 
+;; defautoload doesn't seem to work with `~a` due to keyword args (?)
+;; so do a normal eager require (sorry).
+(require (only-in racket/format ~a))
+
 (define current-log-receiver-thread (make-parameter #f))
 (define global-logger (current-logger))
+(define other-level 'fatal) ;for "all other" loggers
 
-(defcommand log "<level>"
+;; Default some specific loggers one notch above their "noisy"
+;; level. That way, if someone sets "all other" loggers to e.g. debug,
+;; these won't get noisy. They need to be cranked up explicitly.
+(define logger-levels (make-hasheq '([cm-accomplice . warning]
+                                     [gc . info])))
+
+(defcommand log "<opt> ..."
   "control log output"
-  ["Starts (or stops) logging events at the given level.  The level should be"
+  ["  ,log                  ;show the levels currently in effect."
-   "one of the valid racket logging levels, or #f for no logging.  For"
+   "  ,log <logger> <level> ;set logger to show level"
-   "convenience, the level can also be #t (maximum logging) or an integer"
+   "  ,log <logger> default ;set logger to use the default, 'all other' level."
-   "(with 0 for no logging, and larger numbers for more logging output)."]
+   "  ,log <level>          ;set the default level, for 'all other' loggers."
-  (define levels '(#f fatal error warning info debug))
+   "  Valid levels: none, fatal, error, warning, info, debug."]
-  (define level
+  (define (update)
-    (let ([l (getarg 'sexpr)])
+    (show-logger-levels) ;handy to show new values
-      (cond [(memq l levels) l]
+    (cond [(current-log-receiver-thread) => kill-thread])
-            [(memq l '(#f none -)) #f]
+    (let* ([args (append (list global-logger)
-            [(memq l '(#t all +)) (last levels)]
+                         (flatten (for/list ([(k v) logger-levels])
-            [(not (integer? l))
+                                    (list v k)))
-             (cmderror "bad level, expecting one of: ~s" levels)]
+                         (list other-level))]
-            [(<= l 0) #f]
+           [r (apply make-log-receiver args)])
-            [(< l (length levels)) (list-ref levels l)]
-            [else (last levels)])))
-  (cond [(current-log-receiver-thread) => kill-thread])
-  (when level
-    (let ([r (make-log-receiver global-logger level)])
       (current-log-receiver-thread
        (thread
         (λ ()
-          (let loop ()
+           (let loop ()
-            (match (sync r)
+             (match (sync r)
-              [(vector l m v name)
+               [(vector l m v _)
-               (display (format "; [~a] ~a~a\n"
+                (display (format "; [~a] ~a~a\n"
-                                l m (if v (format " ~.s" v) "")))
+                                 l m
-               (flush-output)])
+                                 ;; Print v unless opaque/useless
-            (loop))))))))
+                                 ;; "#<continuation-mark-set>"
+                                 (if (and v (not (continuation-mark-set? v)))
+                                     (format " ~.s" v) "")))
+                (flush-output)])
+             (loop)))))))
+  (define (show-logger-levels)
+    (define wid 20)
+    (define (pr k v)
+      (printf "; ~a ~a\n"
+              (~a k
+                  #:min-width wid
+                  #:max-width wid
+                  #:limit-marker "...")
+              v))
+    (pr "Logger" "Level")
+    (pr (make-string wid #\-) "-------")
+    (for ([(k v) logger-levels])
+      (pr k v))
+    (pr "[all other]" other-level))
+  (match (getarg 'sexpr 'list)
+    [(list) (show-logger-levels)]
+    [(list (and level (or 'none 'fatal 'error 'warning 'info 'debug)))
+     (set! other-level level)
+     (update)]
+    [(list logger 'default)
+     (hash-remove! logger-levels logger)
+     (update)]
+    [(list logger (and level (or 'none 'fatal 'error 'warning 'info 'debug)))
+     (hash-set! logger-levels logger level)
+     (update)]
+    [_ (cmderror "Bad argument. Enter \",help log\" for usage.")]))
 
 ;; ----------------------------------------------------------------------------
 ;; meta evaluation hook