Allow explicitly providing a parent logger to define-logger

pkgs/racket-doc/scribblings/reference/logging.scrbl

@@ -132,7 +132,9 @@ Reports @racket[logger]'s default topic, if any.}
 A @tech{parameter} that determines the @tech{current logger}.}
 
 
-@defform[(define-logger id)]{
+@defform[(define-logger id maybe-parent)
+         #:grammar ([maybe-parent (code:line) (code:line #:parent parent-expr)])
+         #:contracts ([parent-expr (or/c logger? #f)])]{
 
 Defines @racketkeywordfont{log-}@racket[id]@racketkeywordfont{-fatal},
 @racketkeywordfont{log-}@racket[id]@racketkeywordfont{-error},
@@ -142,10 +144,14 @@ Defines @racketkeywordfont{log-}@racket[id]@racketkeywordfont{-fatal},
 like @racket[log-fatal], @racket[log-error],@racket[log-warning],
 @racket[log-info], and @racket[log-debug]. The @racket[define-logger]
 form also defines @racket[id]@racketidfont{-logger}, which is a logger with
-default topic @racket['@#,racket[id]] that is a child of @racket[(current-logger)];
-the @racketkeywordfont{log-}@racket[id]@racketkeywordfont{-fatal},
-@|etc| forms use this new logger. The new logger is
-created when @racket[define-logger] is evaluated.}
+default topic @racket['@#,racket[id]] that is a child of the result of
+@racket[parent-expr] (if @racket[parent-expr] does not produce @racket[#f]),
+or of @racket[(current-logger)] if @racket[parent-expr] not provided; the
+@racketkeywordfont{log-}@racket[id]@racketkeywordfont{-fatal}, @|etc| forms
+use this new logger. The new logger is created when @racket[define-logger]
+is evaluated.
+
+@history[#:changed "7.1.0.9" @elem{Added the @racket[#:parent] option.}]}
 
 @; ----------------------------------------
 @section{Logging Events}

pkgs/racket-test-core/tests/racket/logger.rktl

@@ -290,6 +290,35 @@
   ;; If receiver is GCed, then this will block
   (sync s))
 
+; --------------------
+; `define-logger` with explicit parent
+
+(let ()
+  (define-logger parent)
+  (define-logger child #:parent parent-logger)
+  (define r (make-log-receiver parent-logger 'warning 'child))
+  (log-child-debug "debug")
+  (test #f sync/timeout 0 r)
+  (log-child-warning "warning")
+  (test "child: warning" (lambda (v) (vector-ref v 1)) (sync r)))
+
+(let ()
+  (define-logger parent)
+  (define parent-receiver (make-log-receiver parent-logger 'warning 'no-parent))
+  (parameterize ([current-logger parent-logger])
+    (define-logger no-parent #:parent #f)
+    (define no-parent-receiver (make-log-receiver no-parent-logger 'warning 'no-parent))
+    (log-no-parent-warning "warning")
+    (test #f sync/timeout 0 parent-receiver)
+    (test "no-parent: warning" (lambda (v) (vector-ref v 1)) (sync no-parent-receiver))))
+
+(err/rt-test
+ (let ()
+   (define-logger test #:parent 'not-a-logger)
+   (void))
+ exn:fail:contract?
+ #rx"define-logger: contract violation.+expected: \\(or/c logger\\? #f\\).+given: 'not-a-logger")
+
 ; --------------------
 
 (report-errs)

racket/collects/racket/private/logger.rkt

@@ -27,15 +27,17 @@
   (define-syntax log-info (make-define-log 'info #'(current-logger) #'(logger-name l)))
   (define-syntax log-debug (make-define-log 'debug #'(current-logger) #'(logger-name l)))
 
-  (define (check-logger who)
-    (lambda (v)
-      (unless (logger? v)
-        (raise-argument-error who "logger?" v))
-      v))
+  (define (check-logger-or-false who v)
+    (unless (or (not v) (logger? v))
+      (raise-argument-error who "(or/c logger? #f)" v))
+    v)
 
   (define-syntax (define-logger stx)
     (syntax-case stx ()
-      [(_ X)
+      [(d-l X)
+       (syntax/loc stx
+         (d-l X #:parent (current-logger)))]
+      [(d-l X #:parent parent)
        (let* ([X #'X]
               [mk (lambda (mode)
                     (datum->syntax X (string->symbol (format "log-~a-~a" (syntax-e X) mode)) X))])
@@ -50,7 +52,7 @@
                         (datum->syntax X (string->symbol (format "~a-logger" (syntax-e X))) X)]
                        [X X])
            #'(begin
-               (define X-logger (make-logger 'X (current-logger)))
+               (define X-logger (make-logger 'X (check-logger-or-false 'd-l parent)))
                (define-syntax log-X-fatal (make-define-log 'fatal #'X-logger #''X))
                (define-syntax log-X-error (make-define-log 'error #'X-logger #''X))
                (define-syntax log-X-warning (make-define-log 'warning #'X-logger #''X))