add racket/logging

pollen/private/external/logging.rkt

@@ -0,0 +1,69 @@
+#lang racket/base
+
+;; 181030: Needed for compatibility with Racket 6.0.
+;; This module introduced until 6.3.
+
+(require racket/contract/base)
+
+(provide log-level/c)
+
+(define log-level/c (or/c 'none 'fatal 'error 'warning 'info 'debug))
+(define log-spec? (listof (or/c symbol? #f)))
+(define log-event? (vector-immutable/c log-level/c string? any/c (or/c symbol? #f)))
+
+(provide/contract [with-intercepted-logging
+                   (->* ((-> log-event? any)
+                         (-> any)
+                         log-level/c)
+                        (#:logger logger?)
+                        #:rest log-spec?
+                        any)]
+                  [with-logging-to-port
+                   (->* (output-port? (-> any) log-level/c)
+                        (#:logger logger?)
+                        #:rest log-spec?
+                        any)])
+
+(define (receiver-thread receiver stop-chan intercept)
+  (thread
+   (lambda ()
+     (define (clear-events)
+       (let ([l (sync/timeout 0 receiver)])
+         (when l ; still something to read
+           (intercept l) ; interceptor gets the whole vector
+           (clear-events))))
+     (let loop ()
+       (let ([l (sync receiver stop-chan)])
+         (cond [(eq? l 'stop)
+                ;; we received all the events we were supposed
+                ;; to get, read them all (w/o waiting), then
+                ;; stop
+                (clear-events)]
+               [else ; keep going
+                (intercept l)
+                (loop)]))))))
+
+(define (with-intercepted-logging interceptor proc #:logger [logger #f]
+                                  . log-spec)
+  (let* ([orig-logger (current-logger)]
+         ;; Unless we're provided with an explicit logger to monitor we
+         ;; use a local logger to avoid getting messages that didn't
+         ;; originate from proc. Since it's a child of the original logger,
+         ;; the rest of the program still sees the log entries.
+         [logger      (or logger (make-logger #f orig-logger))]
+         [receiver    (apply make-log-receiver logger log-spec)]
+         [stop-chan   (make-channel)]
+         [t           (receiver-thread receiver stop-chan interceptor)])
+    (begin0
+        (parameterize ([current-logger logger])
+          (proc))
+      (channel-put stop-chan 'stop) ; stop the receiver thread
+      (thread-wait t))))
+
+(define (with-logging-to-port port proc #:logger [logger #f] . log-spec)
+  (apply with-intercepted-logging
+         #:logger logger
+         (lambda (l) (displayln (vector-ref l 1) ; actual message
+                                port))
+         proc
+         log-spec))