-

main.rkt

@@ -0,0 +1,125 @@
+#lang racket
+
+(require (for-syntax racket/syntax)
+         racket/date
+         racket-sprintf
+         )
+
+(provide def-log
+         log-to
+         log-to-file
+         log-to-display
+         )
+
+(define (iso-timestamp)
+  (let* ([d (seconds->date (current-seconds))])
+    (sprintf "%04d-%02d-%02dT%02d:%02d:%02d"
+            (date-year d)
+            (date-month d)
+            (date-day d)
+            (date-hour d)
+            (date-minute d)
+            (date-second d))))
+
+(define (log-to* receiver log-callbacks)
+  (void
+   (thread
+    (λ () (let loop ()
+            (let* ((v (sync receiver))
+                   (level (vector-ref v 0))
+                   (msg (vector-ref v 1))
+                   (data (vector-ref v 2))
+                   (dt (car data))
+                   (topic (cadr data))
+                   )
+              (for-each (λ (e)
+                          (let ((callback (cdr e)))
+                            (callback topic level dt msg)))
+                        (log-callbacks))
+              )
+            (loop)
+            )
+      )
+    )
+   )
+  )
+
+(define-syntax (log-to stx)
+  (syntax-case stx ()
+    ((_ id name callback)
+     (with-syntax ([log-callbacks (format-id #'id "log-callbacks-~a" #'id)])
+       #'(set! log-callbacks (append
+                              (filter (λ (e)
+                                        (not (eq? (car e) 'name)))
+                                      log-callbacks) (list (cons 'name callback))))
+       )
+     )
+    )
+  )
+
+(define-syntax log-to-display
+  (syntax-rules (display)
+    ((_ id)
+     (log-to id display
+             (λ (topic level dt msg)
+               (displayln (format "~a:~a:~a:~a" topic level dt msg)))
+             )
+     )
+    )
+  )
+
+(define-syntax log-to-file
+  (syntax-rules (file)
+    ((_ id filename)
+     (let ((out (open-output-file filename #:exists 'replace)))
+       (log-to id file (λ (topic level dt msg)
+                         (displayln (format "~a:~a:~a:~a" topic level dt msg) out)
+                         (flush-output out))
+             )
+       )
+     )
+    )
+  )
+
+
+(define-syntax def-log2
+  (syntax-rules ()
+    ((_ id parent receiver log-callbacks dbgn infon warnn errn fataln)
+     (begin
+       (define l (make-logger 'id parent))
+       (define log-callbacks '())
+       (define receiver (make-log-receiver l 'debug))
+       (define (log level msg args)
+         (log-message l level #f (apply format (cons msg args)) (list (iso-timestamp) 'id)))
+       (define (dbgn msg . args) (log 'debug msg args))
+       (define (infon msg . args) (log 'info msg args))
+       (define (warnn msg . args) (log 'warning msg args))
+       (define (errn msg . args) (log 'error msg args))
+       (define (fataln msg . args) (log 'fatal msg args))
+       (log-to* receiver (λ () log-callbacks))
+       )
+     )
+    )
+  )
+
+
+(define-syntax (def-log stx)
+  (syntax-case stx ()
+    ((_ id parent)
+     (with-syntax ([receiver (format-id #'id "receiver-~a" #'id)]
+                   [callbacks (format-id #'id "log-callbacks-~a" #'id)]
+                   [dbg-name (format-id #'id "dbg-~a" #'id)]
+                   [info-name (format-id #'id "info-~a" #'id)]
+                   [warn-name (format-id #'id "warn-~a" #'id)]
+                   [err-name (format-id #'id "err-~a" #'id)]
+                   [fatal-name (format-id #'id "fatal-~a" #'id)]
+                   )
+       #'(def-log2 id parent receiver callbacks dbg-name info-name warn-name err-name fatal-name)
+       )
+     )
+    ((_ id)
+     #'(def-log id (current-logger))
+     )
+    )
+  )
+