-

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
+

info.rkt

@@ -0,0 +1,28 @@
+#lang info
+
+(define pkg-authors '(hnmdijkema))
+(define version "0.1.1")
+(define license 'Apache-2.0)   
+(define collection "simple-log")
+(define pkg-desc "simple-log - A simple wrapper around the racket logging system")
+
+(define scribblings
+  '(
+    ("scrbl/simple-log.scrbl" () (library) "simple-log")
+    )
+  )
+
+(define deps
+ '("racket/base"
+   "racket-sprintf"
+   )
+  )
+
+(define build-deps
+  '("racket-doc"
+    "draw-doc"
+    "rackunit-lib"
+    "scribble-lib"
+    "net-doc"
+    ))
+

main.rkt

@@ -0,0 +1,185 @@
+#lang racket
+
+(require (for-syntax racket/syntax)
+         racket/date
+         racket-sprintf
+         data/queue
+         )
+
+(provide sl-def-log
+         sl-log-to
+         sl-log-to-file
+         sl-log-to-display
+         sl-log-to-file&display
+         sl-set-log-level
+         sl-log-level
+         )
+
+(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-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
+    (λ () (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))
+                   (lc (log-callbacks))
+                   )
+
+              (enqueue! log-queue (list topic level dt msg))
+              (unless (null? lc)
+                (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)
+            )
+      )
+    )
+   )
+  )
+
+(define-syntax sl-log-to
+  (syntax-rules (log-callbacks)
+    ((_ name callback)
+     (set! log-callbacks (append
+                          (filter (λ (e) (not (eq? (car e) 'name)))
+                                  log-callbacks)
+                          (list (cons 'name callback)))
+           )
+     )
+    )
+  )
+
+(define (sl-log-to-file&display filename)
+  (log-to-display*)
+  (log-to-file* filename)
+  (dbg-simple-log "log to file and display enabled with file ~a" filename)
+  )
+
+(define (log-to-display*)
+  (sl-log-to display
+            (λ (topic level dt msg)
+               (displayln (format "~a:~a:~a:~a" topic level dt msg)))
+             )
+  )
+  
+
+(define (sl-log-to-display)
+  (log-to-display*)
+  (dbg-simple-log "log-to-display enabled")
+  )
+
+(define (log-to-file* filename)
+     (let ((out (open-output-file filename #:exists 'replace)))
+       (sl-log-to file (λ (topic level dt msg)
+                       (displayln (format "~a:~a:~a:~a" topic level dt msg) 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 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 (sl-def-log stx)
+  (syntax-case stx (log-callbacks)
+    ((_ id prefix parent)
+     (with-syntax ([receiver (format-id #'id "receiver-~a" #'prefix)]
+                   [dbg-name (format-id #'id "dbg-~a" #'prefix)]
+                   [info-name (format-id #'id "info-~a" #'prefix)]
+                   [warn-name (format-id #'id "warn-~a" #'prefix)]
+                   [err-name (format-id #'id "err-~a" #'prefix)]
+                   [fatal-name (format-id #'id "fatal-~a" #'prefix)]
+                   )
+       #'(def-log2 id parent receiver log-callbacks dbg-name info-name warn-name err-name fatal-name)
+       )
+     )
+    ((_ id name)
+     #'(sl-def-log id name #f)
+     )
+    ((_ id)
+     #'(sl-def-log id id #f)
+     )
+    )
+  )
+
+(sl-def-log simple-log)
+
+
+

scrbl/.gitignore

@@ -0,0 +1,5 @@
+*.css
+*.html
+*.js
+*~
+*.bak

scrbl/simple-log.scrbl

@@ -0,0 +1,154 @@
+#lang scribble/manual
+
+@(require (for-label racket/base))
+
+@title{simple-log}
+@author[@author+email["Hans Dijkema" "hans@dijkewijk.nl"]]
+
+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.
+
+@section{API}
+
+@defmodule["simple-log"]
+
+@defform*[((sl-def-log id)
+           (sl-def-log id name)
+           (sl-def-log id name parent))]{
+
+Defines a logger with topic @racket['id] and creates:
+
+@itemlist[#:style 'compact
+ @item{@racket[dbg-id]}
+ @item{@racket[info-id]}
+ @item{@racket[warn-id]}
+ @item{@racket[err-id]}
+ @item{@racket[fatal-id]}
+]
+
+Note. If name is given, id @racket[dbg-prefix], etc. will be generated instead of @racket[dbg-id], etc.
+
+Each procedure has shape:
+
+@racketblock[
+(proc msg arg ...)
+]
+
+The message is formatted via @racket[format] and emitted with a timestamp
+(@litchar{YYYY-MM-DDTHH:MM:SS}) and topic @racket['id].
+
+If @racket[parent] is omitted, the @racket[#f] is used as "parent logger".
+
+A background thread is started that receives log events and forwards them
+to the registered callbacks.
+}
+
+@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[
+(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>"
+]
+}
+
+@defproc[(sl-log-to-display) void?]{
+
+Registers a callback that writes log lines to the current output port
+using @racket[displayln].
+
+Format:
+
+@racketblock[
+"<topic>:<level>:<timestamp>:<message>"
+]
+}
+
+@defproc[(sl-log-to-file&display [filename path-string?]) void?]{
+
+Equivalent to combining @racket[sl-log-to-display] and
+@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.