1
2(module logger '#%kernel
3  (#%require "define-et-al.rkt" "qq-and-or.rkt" "define.rkt"
4             (for-syntax '#%kernel "stx.rkt" "define-et-al.rkt" "qq-and-or.rkt"
5                         "stxcase-scheme.rkt"))
6
7  (#%provide log-fatal log-error log-warning log-info log-debug
8             define-logger)
9
10  (define-for-syntax (make-define-log mode X-logger-stx name)
11    (lambda (stx)
12      (with-syntax ([X-logger X-logger-stx]
13                    [mode mode]
14                    [name name])
15        (syntax-case stx ()
16          [(_ str-expr)
17           #'(let ([l X-logger])
18               (when (log-level? l 'mode name)
19                 (log-message l 'mode str-expr (current-continuation-marks))))]
20          [(_ str-expr arg ...)
21           #'(let ([l X-logger])
22               (when (log-level? l 'mode name)
23                 (log-message l 'mode (format str-expr arg ...) (current-continuation-marks))))]))))
24
25  (define-syntax log-fatal (make-define-log 'fatal #'(current-logger) #'(logger-name l)))
26  (define-syntax log-error (make-define-log 'error #'(current-logger) #'(logger-name l)))
27  (define-syntax log-warning (make-define-log 'warning #'(current-logger) #'(logger-name l)))
28  (define-syntax log-info (make-define-log 'info #'(current-logger) #'(logger-name l)))
29  (define-syntax log-debug (make-define-log 'debug #'(current-logger) #'(logger-name l)))
30
31  (define (check-logger-or-false who v)
32    (unless (or (not v) (logger? v))
33      (raise-argument-error who "(or/c logger? #f)" v))
34    v)
35
36  (define-syntax (define-logger stx)
37    (syntax-case stx ()
38      [(d-l X)
39       (syntax/loc stx
40         (d-l X #:parent (current-logger)))]
41      [(d-l X #:parent parent)
42       (let* ([X #'X]
43              [logger-local-introduced (syntax-local-introduce X)]
44              [logger-name-size (string-length (symbol->string (syntax-e X)))]
45              [mk-binder (lambda (id starting-point)
46                           (vector (syntax-local-introduce id)
47                                   starting-point logger-name-size 0.5 0.5
48                                   logger-local-introduced
49                                   0 logger-name-size 0.5 0.5))]
50              [mk (lambda (mode)
51                    (datum->syntax X (string->symbol (format "log-~a-~a" (syntax-e X) mode)) X))])
52         (unless (identifier? X)
53           (raise-syntax-error #f "not an identifier" stx X))
54         (with-syntax ([log-X-fatal (mk 'fatal)]
55                       [log-X-error (mk 'error)]
56                       [log-X-warning (mk 'warning)]
57                       [log-X-info (mk 'info)]
58                       [log-X-debug (mk 'debug)]
59                       [X-logger
60                        (datum->syntax X (string->symbol (format "~a-logger" (syntax-e X))) X)]
61                       [X X])
62           (syntax-property
63            #'(begin
64                (define X-logger (make-logger 'X (check-logger-or-false 'd-l parent)))
65                (define-syntax log-X-fatal (make-define-log 'fatal #'X-logger #''X))
66                (define-syntax log-X-error (make-define-log 'error #'X-logger #''X))
67                (define-syntax log-X-warning (make-define-log 'warning #'X-logger #''X))
68                (define-syntax log-X-info (make-define-log 'info #'X-logger #''X))
69                (define-syntax log-X-debug (make-define-log 'debug #'X-logger #''X)))
70            'sub-range-binders
71            (map
72             mk-binder
73             (list #'X-logger #'log-X-fatal #'log-X-error #'log-X-warning #'log-X-info #'log-X-debug)
74             (list 0 4 4 4 4 4)))))])))
75