;; 
;; %%HEADER%%
;; 

(use missbehave defstruct fmt fmt-color data-structures chicken-syntax args posix files)
  
(define use-colors #t)

(define command-line-options
  (list (args:make-option (h help) #:none "Display this help" (usage port: (current-output-port) status: 0))
        (args:make-option (n nocolor) #:none "Don't display colors" (set! use-colors #f))
        (args:make-option (t tags) (required: "TAG") "Tags to filter. Can be used multiple times" )))

(define (usage #!key (port (current-error-port)) (status 1))
  (with-output-to-port port
    (lambda ()
      (print "Usage: " (car (argv)) " [options ...] file ...")
      (newline)
      (print (args:usage command-line-options))))
  (exit status))

(when (= 1 (length (argv)))
  (usage))
  

(defstruct report-agenda failed successful pending)


(define (make-pretty-reporter)
  (let ((agenda (make-report-agenda failed: 0 successful: 0 pending: 0)))
    (lambda (data #!key (mode 'adhoc))
      (case mode
        ((adhoc)   (report-adhoc! data agenda))
        ((summary) (report-summary! data agenda))))))

(define (report-adhoc! data agenda)
  (cond
   ((context? data)
    (if use-colors
        (fmt #t (fmt-bold (context-description data)))
        (fmt #t (context-description data)))
    (newline))
   ((example? data) #t)
   ((example-result? data)
    (cond
     ((example-failed? data)
      (report-example 'failed data)
      (agenda-increment-failed! agenda))
     ((example-pending? data)
      (report-example 'pending data)
      (agenda-increment-pending! agenda))
     (else
      (report-example 'success data)
      (agenda-increment-successful! agenda))))))

(define (report-summary! data agenda)
  (if use-colors
      (report-summary-with-colors! data agenda)
      (report-summary-plain! data agenda)))

(define (report-summary-with-colors! data agenda)
  (newline)
  (newline)
  (fmt #t (cat
           (fmt-bold
            (cat
             "Total: "
             (+ (report-agenda-failed agenda)
                (report-agenda-pending agenda)
                (report-agenda-successful agenda))))
           " "
           (fmt-green (fmt-bold
                       (cat
                        "Successful: "
                        (report-agenda-successful agenda)
                        " ")))
           (fmt-yellow (fmt-bold
                        (cat
                         "Pending: "
                         (report-agenda-pending agenda)
                         " ")))
           (fmt-red (fmt-bold
                     (cat
                      "Failures: "
                      (report-agenda-failed agenda)
                      " ")))))
  (newline)
  (zero? (report-agenda-failed agenda)))

(define (report-summary-plain! data agenda)
  (newline)
  (newline)
  (printf "Total: ~A Successful: ~A Pending: ~A Failures: ~A"
    (+ (report-agenda-failed agenda)
       (report-agenda-pending agenda)
       (report-agenda-successful agenda))
    (report-agenda-successful agenda)
    (report-agenda-pending agenda)
    (report-agenda-failed agenda))
  (newline)
  (zero? (report-agenda-failed agenda)))

(define (report-example status result)
  (if use-colors
      (report-example-colors status result)
      (report-example-plain status result)))

(define (report-example-colors status result)
  (let ((example (example-result-example result)))
    (case status
      ((success)
       (fmt #t (cat (space-to 2) (fmt-green (cat "It " (example-description example)))))
       (newline))
      ((pending)
       (fmt #t (cat (space-to 2) (fmt-yellow (cat "[P] It " (example-description example)))))
       (newline))
      (else
       (fmt #t (cat (space-to 2) (fmt-red (cat "[F] It " (example-description example)))))
       (newline)
       (fmt #t (cat (space-to 4) (fmt-red (example-result-messages result))))
       (newline)))))

(define (report-example-plain status result)
  (let ((example (example-result-example result)))
    (case status
      ((success)
       (fmt #t (cat (space-to 2) (cat "It " (example-description example))))
       (newline))
      ((pending)
       (fmt #t (cat (space-to 2) (cat "[P] It " (example-description example))))
       (newline))
      (else
       (fmt #t (cat (space-to 2)  (cat "[F] It " (example-description example))))
       (newline)
       (fmt #t (cat (space-to 4)  (example-result-messages result)))
       (newline)))))

(define (agenda-increment-successful! agenda)
  (report-agenda-successful-set! agenda (+ 1 (report-agenda-successful agenda))))

(define (agenda-increment-failed! agenda)
  (report-agenda-failed-set! agenda (+ 1 (report-agenda-failed agenda))))

(define (agenda-increment-pending! agenda)
  (report-agenda-pending-set! agenda (+ 1 (report-agenda-pending agenda))))

(define (run-files files #!optional (include-filter #f) (exclude-filter #f))
  (run-specification
   (call-with-specification
    (make-empty-specification)
    (lambda ()
      (for-each (lambda (file)
                  (let ((absolute-path (absolutize-path file)))                    
                    (unless (file-exists? absolute-path)
                      (error "The file " absolute-path " does not exist"))
                    (eval-spec-file absolute-path)))
                files)))
   include: include-filter
   exclude: exclude-filter
   reporter: (make-pretty-reporter)))

(define (eval-spec-file file)
  (let ((content (read-file file)))
    (unless (null? content)
      (eval (decorate-content content file)))))

(define (decorate-content content file)
  `(begin
     (use missbehave)
     ,@content))

(define (absolutize-path path)
  (let ((cwd (current-directory)))
    (if (absolute-pathname? path)
        (normalize-pathname path)
        (normalize-pathname (conc cwd "/" path)))))

(define (extract-tags options)
  (fold (lambda (element tags)
          (if (eq? (car element) 't)
              (cons  (string-split (cdr element) ":") tags)
              tags))
        '()
        options))

(define (create-include-filter tags)
  (fold (lambda (tag filter)
          (let ((label (string-translate* (car tag) '(("@" . "")))))
            (if (not (equal? "~" (string-take label 1)))
                (if (= 1 (length tag))
                    (cons (list (string->symbol label)) filter)
                    (cons (list (string->symbol label) (string->symbol (cadr tag))) filter))
                filter)))
        '()
        tags))

(define (create-exclude-filter tags)
  (fold (lambda (tag filter)
          (let ((label (string-translate* (car tag) '(("@" . "")))))
            (if (equal? "~" (string-take label 1))
                (if (= 1 (length tag))
                    (cons (list (string->symbol (string-drop label 1))) filter)
                    (cons (list (string->symbol (string-drop label 1)) (string->symbol (cadr tag))) filter))
                filter)))
        '()
        tags))


(receive (options files) (args:parse (command-line-arguments) command-line-options)
  (let* ((tags (extract-tags options))
         (include-filter (create-include-filter tags))
         (exclude-filter (create-exclude-filter tags)))
    (if (run-files
         files
         (if (null? include-filter) #f include-filter)
         (if (null? exclude-filter) #f exclude-filter))
        (exit 0)
        (exit 2))))