logger-typed

quad/logger-typed.rkt

@@ -0,0 +1,46 @@
+#lang typed/racket/base
+(require (for-syntax racket/base))
+(require/typed "world-typed.rkt" [world:logging-level (Parameterof Log-Level)])
+(require/typed racket/date [current-date (-> Any)]
+               [date->string ((Any) (Any) . ->* . String)])
+(require racket/match)
+(provide (all-defined-out))
+
+(define-syntax-rule (define-orphan-logger name)
+  (begin
+    (define remember-cl (current-logger))
+    (define dummy-cl (make-logger))
+    (current-logger dummy-cl)
+    (define-logger name)
+    (current-logger remember-cl)))
+
+(define levels '(none fatal error warning info debug))
+
+(define-logger quad)
+
+(define-syntax-rule (activate-logger logger)
+  (begin
+    (define logger-receiver (make-log-receiver logger (world:logging-level))) 
+    (define log-file (build-path (current-directory) (format "~a.txt" 'logger)))
+    (with-output-to-file log-file #:exists 'truncate void)
+    (void (thread
+           (λ ()
+             (let loop ()
+               (match (sync logger-receiver)
+                 [(vector event-level event-message event-value name)
+                  (define msg (format "[~a] ~a\n" event-level event-message))
+                  ;   (eprintf msg)
+                  (flush-output)
+                  (with-output-to-file log-file #:exists 'append (λ () (display msg)))])
+               (loop))))
+          (log-quad-info "started at ~a" (date->string (current-date) #t)))))
+
+(define-syntax-rule (log-quad-debug-report x)
+  (begin 
+    (log-quad-debug "~a = ~a" 'x x)
+    x))
+
+(define-syntax-rule (log-quad-debug* xs)
+  (when (equal? (world:logging-level) 'debug)
+    (map (λ(x) (log-quad-debug x)) xs)))
+