#lang racket

(require (for-syntax racket/syntax)
         racket/date
         racket-sprintf
         )

(provide def-log
         log-to
         log-to-file
         log-to-display
         )

(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-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))
                   )
              (for-each (λ (e)
                          (let ((callback (cdr e)))
                            (callback topic level dt msg)))
                        (log-callbacks))
              )
            (loop)
            )
      )
    )
   )
  )

(define-syntax (log-to stx)
  (syntax-case stx ()
    ((_ id name callback)
     (with-syntax ([log-callbacks (format-id #'id "log-callbacks-~a" #'id)])
       #'(set! log-callbacks (append
                              (filter (λ (e)
                                        (not (eq? (car e) 'name)))
                                      log-callbacks) (list (cons 'name callback))))
       )
     )
    )
  )

(define-syntax log-to-display
  (syntax-rules (display)
    ((_ id)
     (log-to id display
             (λ (topic level dt msg)
               (displayln (format "~a:~a:~a:~a" topic level dt msg)))
             )
     )
    )
  )

(define-syntax log-to-file
  (syntax-rules (file)
    ((_ id filename)
     (let ((out (open-output-file filename #:exists 'replace)))
       (log-to id file (λ (topic level dt msg)
                         (displayln (format "~a:~a:~a:~a" topic level dt msg) out)
                         (flush-output out))
             )
       )
     )
    )
  )


(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)))
       (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 (def-log stx)
  (syntax-case stx ()
    ((_ 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)
       )
     )
    ((_ id)
     #'(def-log id (current-logger))
     )
    )
  )