#lang mzscheme

(require scheme/contract
         (all-except srfi/1/list any)
         srfi/13/string
         srfi/19/time
         srfi/26/cut)
         
(require (planet "aif.ss" ("schematics" "macro.plt" 1)))

(require (file "base.ss")
         (file "parameter.ss")
         (file "time.ss"))

;; struct log : symbol
(define-struct log-stream (name) #f)
(define make-log make-log-stream)

(define message-log (make-log 'M))
(define warning-log (make-log 'W))
(define error-log   (make-log 'E))

;; parameter current-log-preamble : (-> (list-of any))
;;
;; Thunk which returns a list of values to be included at the beginning of each log message.
(define-parameter current-log-preamble
  (lambda () null)
  (lambda (val)
    (if (procedure? val)
        val
        (raise-exn exn:fail:unlib
          (format "Expected (symbol -> (list-of string)), received ~a." val))))
  with-log-preamble)

;; parameter current-log-port : (U (parameter output-port) output-port)
;;
;; A parameter containing an output port or an output port
;; to print messages to.
(define-parameter current-log-port
  current-output-port
  (lambda (val)
    (if (output-port? val)
        val
        (raise-exn exn:fail:unlib
          (format "Expected output-port, received ~a." val))))
  with-log-port)

;; log-message : any ... -> integer
;;
;; Prints a message and returns a timestamp as a unique identifier.
(define log-message
  (lambda args
    (log-generic message-log args)))

;; log-warning : any ... -> integer
;;
;; Prints a warning and returns a timestamp as a unique identifier.
(define log-warning
  (lambda args
    (log-generic warning-log args)))

;; log-error : any ... -> integer
;;
;; Prints a error and returns a timestamp as a unique identifier.
(define log-error
  (lambda args
    (log-generic error-log args)))

;; log-generic : log (list-of any) -> time-tai
;;
;; Prints a generic message and returns a timestamp as a unique identifier.
(define log-generic
  (lambda (log-stream message-components)
    (let* ([time  (current-time time-tai)]
           [items (cons (log-stream-name log-stream)
                        (append ((current-log-preamble)) message-components))]
           [out   (aif log-port parameter? (current-log-port)
                       (log-port)
                       log-port)])
      (display (string-join (map (cut format "~s" <>) items) ",") out)
      (newline out)
      time)))

(provide with-log-preamble
         with-log-port)

(provide/contract
 [struct log-stream    ([name symbol?])]
 [make-log             (-> symbol? log-stream?)]
 [message-log          log-stream?]
 [warning-log          log-stream?]
 [error-log            log-stream?]
 [current-log-preamble (parameter/c procedure?)]
 [current-log-port     (parameter/c output-port?)]
 [log-message          (->* () () #:rest any/c time-tai?)]
 [log-warning          (->* () () #:rest any/c time-tai?)]
 [log-error            (->* () () #:rest any/c time-tai?)]
 [log-generic          (-> log-stream? list? time-tai?)])