Update packages

elpa/racket-mode-20181004.309/racket/logger.rkt

@@ -0,0 +1,93 @@
+#lang at-exp racket/base
+
+(require racket/match
+         racket/format
+         racket/tcp
+         "elisp.rkt"
+         "util.rkt")
+
+(provide start-logger-server)
+
+;; "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 (start-logger-server port launch-token)
+  (void (thread (logger-thread port launch-token))))
+
+(define ((logger-thread port launch-token))
+  (define listener (tcp-listen port 4 #t "127.0.0.1"))
+  (let accept ()
+    (define-values (in out) (tcp-accept listener))
+    (unless (or (not launch-token)
+                      (equal? launch-token (elisp-read in)))
+            (display-commented "Authorization failed; exiting")
+            (exit 1))
+    ;; Assumption: Any network fail means the client has disconnected,
+    ;; therefore we should go back to waiting to accept a connection.
+    (with-handlers ([exn:fail:network? void])
+      (let wait ([receiver never-evt])
+        ;; Assumption: Our Emacs code will write complete sexprs,
+        ;; therefore when `in` becomes ready `read` will return
+        ;; without blocking.
+        (match (sync in receiver)
+          [(? input-port? in) (match (read in)
+                                [(? eof-object?) (void)]
+                                [v               (wait (make-receiver v))])]
+          [(vector level message _v topic)
+           (parameterize ([current-output-port out])
+             (display-log level topic message)
+             (flush-output))
+           (wait receiver)])))
+    (close-input-port in)
+    (close-output-port out)
+    (accept)))
+
+(define (display-log level topic message)
+  (display (label level))
+  (display " ")
+  (display (ensure-topic-in-message topic message))
+  (newline))
+
+(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)]))))