-

Makefile

@@ -0,0 +1,10 @@
+
+
+all:
+	@echo "use make clean"
+
+clean:
+	find . -type f -name "*~" -exec rm {} \;
+	find . -type f -name "*.bak" -exec rm {} \;
+	rm -f scrbl/*.html scrbl/*.js scrbl/*.css
+

main.rkt

@@ -3,12 +3,16 @@
 (require (for-syntax racket/syntax)
          racket/date
          racket-sprintf
+         data/queue
          )
 
-(provide def-log
+(provide sl-def-log
-         log-to
+         sl-log-to
-         log-to-file
+         sl-log-to-file
-         log-to-display
+         sl-log-to-display
+         sl-log-to-file&display
+         sl-set-log-level
+         sl-log-level
          )
 
 (define (iso-timestamp)
@@ -21,6 +25,40 @@
             (date-minute d)
             (date-second d))))
 
+
+(define log-callbacks #f)
+(set! log-callbacks '())
+
+(define log-level #f)
+(set! log-level 'debug)
+
+(define max-log-queue-len 1000)
+(define log-queue (make-queue))
+
+(define (sl-set-log-level l)
+  (if (or
+       (eq? l 'debug)
+       (eq? l 'info)
+       (eq? l 'warning)
+       (eq? l 'warn)
+       (eq? l 'err)
+       (eq? l 'error)
+       (eq? l 'dbg)
+       (eq? l 'fatal))
+      (set! log-level
+            (cond
+              ((eq? l 'err) 'error)
+              ((eq? l 'warn) 'warning)
+              ((eq? l 'dbg) 'debug)
+              (else l)))
+      (error "Log level must be 'debug ('dbg), 'info, 'warning ('warn), 'error ('err) or 'fatal")
+      )
+  log-level
+  )
+
+(define (sl-log-level)
+  log-level)
+
 (define (log-to* receiver log-callbacks)
   (void
    (thread
@@ -31,11 +69,21 @@
                    (data (vector-ref v 2))
                    (dt (car data))
                    (topic (cadr data))
+                   (lc (log-callbacks))
                    )
-              (for-each (λ (e)
+
-                          (let ((callback (cdr e)))
+              (enqueue! log-queue (list topic level dt msg))
-                            (callback topic level dt msg)))
+              (unless (null? lc)
-                        (log-callbacks))
+                (for-each (λ (log-entry)
+                            (for-each (λ (e)
+                                        (let ((callback (cdr e)))
+                                          (apply callback log-entry)))
+                                      lc)
+                            )
+                          (queue->list log-queue))
+                (set! log-queue (make-queue)))
+              (when (> (queue-length log-queue) max-log-queue-len)
+                (dequeue! log-queue))
               )
             (loop)
             )
@@ -44,50 +92,56 @@
    )
   )
 
-(define-syntax (log-to stx)
+(define-syntax sl-log-to
-  (syntax-case stx ()
+  (syntax-rules (log-callbacks)
-    ((_ id name callback)
+    ((_ name callback)
-     (with-syntax ([log-callbacks (format-id #'id "log-callbacks-~a" #'id)])
+     (set! log-callbacks (append
-       #'(set! log-callbacks (append
+                          (filter (λ (e) (not (eq? (car e) 'name)))
-                              (filter (λ (e)
+                                  log-callbacks)
-                                        (not (eq? (car e) 'name)))
+                          (list (cons 'name callback)))
-                                      log-callbacks) (list (cons 'name callback))))
+           )
-       )
      )
     )
   )
 
-(define-syntax log-to-display
+(define (sl-log-to-file&display filename)
-  (syntax-rules (display)
+  (log-to-display*)
-    ((_ id)
+  (log-to-file* filename)
-     (log-to id display
+  (dbg-simple-log "log to file and display enabled with file ~a" filename)
-             (λ (topic level dt msg)
+  )
+
+(define (log-to-display*)
+  (sl-log-to display
+            (λ (topic level dt msg)
                (displayln (format "~a:~a:~a:~a" topic level dt msg)))
              )
-     )
-    )
   )
   
-(define-syntax log-to-file
+
-  (syntax-rules (file)
+(define (sl-log-to-display)
-    ((_ id filename)
+  (log-to-display*)
+  (dbg-simple-log "log-to-display enabled")
+  )
+
+(define (log-to-file* filename)
      (let ((out (open-output-file filename #:exists 'replace)))
-       (log-to id file (λ (topic level dt msg)
+       (sl-log-to file (λ (topic level dt msg)
-                         (displayln (format "~a:~a:~a:~a" topic level dt msg) out)
+                       (displayln (format "~a:~a:~a:~a" topic level dt msg) out)
-                         (flush-output out))
+                       (flush-output out))
-             )
+               )
        )
-     )
-    )
   )
 
+(define (sl-log-to-file filename)
+  (log-to-file* filename)
+  (dbg-simple-log "log-to-file enabled with file ~a" filename)
+  )
 
 (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)))
@@ -103,23 +157,26 @@
   )
 
 
-(define-syntax (def-log stx)
+(define-syntax (sl-def-log stx)
-  (syntax-case stx ()
+  (syntax-case stx (log-callbacks)
     ((_ 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)
+       #'(def-log2 id parent receiver log-callbacks dbg-name info-name warn-name err-name fatal-name)
        )
      )
     ((_ id)
-     #'(def-log id (current-logger))
+     #'(sl-def-log id (current-logger))
      )
     )
   )
 
+(sl-def-log simple-log)
+
+
+

scrbl/simple-log.scrbl

@@ -1,90 +1,151 @@
 #lang scribble/manual
 
-@(require (for-label racket/base
+@(require (for-label racket/base))
-                     racket/date
-                     racket/logging
-                     racket-sprintf))
-
-@defmodule{simple-log}
-
-@title{Logging}
 
+@title{simple-log}
 @author[@author+email["Hans Dijkema" "hans@dijkewijk.nl"]]
 
-@section{Overview}
+A small logging layer on top of Racket’s logger system. A log definition
+creates a logger plus five convenience procedures. Messages are formatted
+with @racket[format], timestamped, and dispatched asynchronously to the
+registered callbacks.
 
-Small wrapper around @racket[logger] with per-logger callbacks.
+@section{API}
 
-A logger consists of a @racket[logger], a
+@defmodule["simple-log"]
-@racket[log-receiver] (level @racket['debug]), a mutable
-callback list, five logging procedures, and a background thread
-dispatching messages.
 
-@section{Definition}
+@defform*[((sl-def-log id)
+           (sl-def-log id parent))]{
 
-@defform*[((def-log id)
+Defines a logger with topic @racket['id] and creates:
-           (def-log id parent))]{
 
-Defines a logger @racket[id]. If @racket[parent] is omitted,
+@itemlist[#:style 'compact
-@racket[(current-logger)] is used.
+ @item{@racket[dbg-id]}
-
+ @item{@racket[info-id]}
-Creates:
+ @item{@racket[warn-id]}
-
+ @item{@racket[err-id]}
-@itemlist[
+ @item{@racket[fatal-id]}
- #:style 'compact
- @item{@racket[(make-logger 'id parent)]}
- @item{@racket[(make-log-receiver ... 'debug)]}
- @item{callback list}
- @item{procedures @racket[dbg-id], @racket[info-id],
-       @racket[warn-id], @racket[err-id], @racket[fatal-id]}
 ]
 
-Starts a thread that @racket[sync]s on the receiver and forwards
+Each procedure has shape:
-messages to callbacks.
-}
-
-@section{Logging functions}
-
-@defproc[(dbg-id [msg string?] [arg any/c] ...) void?]
-@defproc[(info-id [msg string?] [arg any/c] ...) void?]
-@defproc[(warn-id [msg string?] [arg any/c] ...) void?]
-@defproc[(err-id [msg string?] [arg any/c] ...) void?]
-@defproc[(fatal-id [msg string?] [arg any/c] ...) void?]
-
-Formats with @racket[(apply format (cons msg args))] and calls
-@racket[log-message].
-
-Attached data:
 
 @racketblock[
-(list (iso-timestamp) 'id)
+(proc msg arg ...)
 ]
 
-@section{Callbacks}
+The message is formatted via @racket[format] and emitted with a timestamp
+(@litchar{YYYY-MM-DDTHH:MM:SS}) and topic @racket['id].
 
-@defform[(log-to id name callback)]{
+If @racket[parent] is omitted, the current logger is used.
 
-Registers @racket[callback] under @racket[name]. Existing entry
+A background thread is started that receives log events and forwards them
-with same name is replaced.
+to the registered callbacks.
+}
 
-Callback signature:
+@defform[(sl-log-to name callback)]{
+
+Registers @racket[callback] under the symbolic name derived from
+@racket[name].
+
+@racket[name] is an identifier (not a runtime value). It is converted at
+macro expansion time to a symbol and used as key in the callback registry.
+
+Invocation shape:
 
 @racketblock[
-(λ (topic level dt msg) ...)
+(callback topic level timestamp message)
+]
+
+with:
+
+@itemlist[#:style 'compact
+ @item{@racket[topic]   — logger topic (symbol)}
+ @item{@racket[level]   — level (symbol)}
+ @item{@racket[timestamp] — @litchar{YYYY-MM-DDTHH:MM:SS}}
+ @item{@racket[message] — formatted string}
+]
+
+An existing callback with the same name is replaced.
+}
+
+@defproc[(sl-log-to-file [filename path-string?]) void?]{
+
+Registers a callback that writes log lines to @racket[filename]. The file
+is opened with @racket['replace].
+
+Format:
+
+@racketblock[
+"<topic>:<level>:<timestamp>:<message>"
 ]
 }
 
-@section{Output helpers}
+@defproc[(sl-log-to-display) void?]{
 
-@defform[(log-to-display id)]{
+Registers a callback that writes log lines to the current output port
+using @racket[displayln].
 
-Registers @racket['display]. Output:
+Format:
 
-@verbatim{topic:level:timestamp:message}
+@racketblock[
+"<topic>:<level>:<timestamp>:<message>"
+]
 }
 
-@defform[(log-to-file id filename)]{
+@defproc[(sl-log-to-file&display [filename path-string?]) void?]{
 
-Registers @racket['file]. File opened with
+Equivalent to combining @racket[sl-log-to-display] and
-@racket[#:exists 'replace]. One line per message, flushed.
+@racket[sl-log-to-file].
 }
+
+@defproc[(sl-set-log-level
+          [l (or/c 'debug 'dbg
+                   'info
+                   'warning 'warn
+                   'error 'err
+                   'fatal)])
+         symbol?]{
+
+Sets the module-wide log level and returns the normalized symbol.
+
+Aliases:
+
+@itemlist[#:style 'compact
+ @item{@racket['dbg]  → @racket['debug]}
+ @item{@racket['warn] → @racket['warning]}
+ @item{@racket['err]  → @racket['error]}
+]
+
+Other values raise an exception.
+
+Note: this value is stored globally. The receiver installed by
+@racket[sl-def-log] itself operates at level @racket['debug].
+}
+
+@defproc[(sl-log-level) symbol?]{
+
+Returns the current module-wide log level (default @racket['debug]).
+}
+
+@section{Generated procedures}
+
+A call to @racket[sl-def-log] creates five procedures. For example:
+
+@racketblock[
+(sl-def-log my-module)
+]
+
+creates:
+
+@defproc[#:link-target? #f
+ (dbg-my-module [msg string?] [arg any/c] ...) void?]{Debug log.}
+@defproc[#:link-target? #f
+ (info-my-module [msg string?] [arg any/c] ...) void?]{Info log.}
+@defproc[#:link-target? #f
+ (warn-my-module [msg string?] [arg any/c] ...) void?]{Warning log.}
+@defproc[#:link-target? #f
+ (err-my-module [msg string?] [arg any/c] ...) void?]{Error log.}
+@defproc[#:link-target? #f
+ (fatal-my-module [msg string?] [arg any/c] ...) void?]{Fatal log.}
+
+All use @racket[format] and emit asynchronously.

scrbl/simple-log.scrbl~

@@ -1,109 +0,0 @@
-#lang scribble/manual
-
-@(require (for-label racket/base
-                     racket/date
-                     racket/logging
-                     racket-sprintf))
-
-@title{Logging}
-
-@author[@author+email["Hans Dijkema" "hans@dijkewijk.nl"]]
-
-@section{Overview}
-
-Small wrapper around @racket[logger] with per-logger callbacks.
-
-A logger consists of a @racket[logger], a
-@racket[log-receiver] (level @racket['debug]), a mutable
-callback list, five logging procedures, and a background thread
-dispatching messages.
-
-@section{Definition}
-
-@defform*[([(def-log id)]
-           [(def-log id parent)])]{
-
-Defines a logger @racket[id]. If @racket[parent] is omitted,
-@racket[(current-logger)] is used.
-
-Creates:
-
-@itemlist[
- #:style 'ordered
- @item{@racket[(make-logger 'id parent)]}
- @item{@racket[(make-log-receiver ... 'debug)]}
- @item{callback list}
- @item{procedures @racket[dbg-id], @racket[info-id],
-       @racket[warn-id], @racket[err-id], @racket[fatal-id]}
-]
-
-Starts a thread that @racket[sync]s on the receiver and forwards
-messages to callbacks.
-}
-
-@section{Logging}
-
-@defproc[(dbg-id [msg string?] [arg any/c] ...) void?]
-@defproc[(info-id [msg string?] [arg any/c] ...) void?]
-@defproc[(warn-id [msg string?] [arg any/c] ...) void?]
-@defproc[(err-id [msg string?] [arg any/c] ...) void?]
-@defproc[(fatal-id [msg string?] [arg any/c] ...) void?]
-
-Formats with @racket[(apply format (cons msg args))] and calls
-@racket[log-message].
-
-Attached data:
-
-@racketblock[
-(list (iso-timestamp) 'id)
-]
-
-@section{Callbacks}
-
-@defform[(log-to id name callback)]{
-
-Registers @racket[callback] under @racket[name]. Existing entry
-with same name is replaced.
-
-Callback signature:
-
-@racketblock[
-(λ (topic level dt msg) ...)
-]
-}
-
-@section{Output helpers}
-
-@defform[(log-to-display id)]{
-
-Registers @racket['display]. Output:
-
-@verbatim{topic:level:timestamp:message}
-}
-
-@defform[(log-to-file id filename)]{
-
-Registers @racket['file]. File opened with
-@racket[#:exists 'replace]. One line per message, flushed.
-}
-
-@section{Timestamp}
-
-@defproc[(iso-timestamp) string?]{
-
-Returns @verbatim{YYYY-MM-DDTHH:MM:SS} using
-@racket[seconds->date] and @racket[sprintf].
-}
-
-@section{Execution}
-
-Per logger thread:
-
-@itemlist[
- #:style 'ordered
- @item{@racket[sync] receiver}
- @item{extract level, msg, data}
- @item{dispatch callbacks}
-]
-
-Callbacks run sequentially in that thread.