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