(import (chicken io)
        (chicken irregex)
        (chicken port)
        (chicken process-context)
        (scsh-process)
        (sexp-diff)
        (ansi-escape-sequences)
        (srfi 1)
        (test))

(define (->string x)
  (with-output-to-string (lambda () (write x))))

(define use-color?
  (let ((TEST_USE_ANSI (get-environment-variable "TEST_USE_ANSI")))
    (or (equal? TEST_USE_ANSI "1")
        (and (terminal-port? (current-output-port))
             (not (equal? TEST_USE_ANSI "0"))))))

(define (red text)   (if use-color? (set-text '(fg-red) text) text))
(define (green text) (if use-color? (set-text '(fg-green) text) text))

(define (expected file)
  (filter-map (lambda (line)
                (and-let* ((match (irregex-search ";> (.*)" line))
                           (tail (irregex-match-substring match 1)))
                   (with-input-from-string tail read)))
              (with-input-from-file file read-lines)))

(define (actual file)
  (map (lambda (message) (take message 3))
       (run/sexps (csc -X ../beaker -A ,file) (= 2 1) (- 1))))

(define (difference a b)
  (let loop ((d (first (sexp-diff a b))))
    (cond ((null? d) '())
          ((or (eq? (car d) #:old) (eq? (car d) #:new))
           (append (take d 2) (loop (drop d 2))))
          ((or (memq #:old (car d)) (memq #:new (car d)))
           (cons (car d) (loop (cdr d))))
          (else (loop (cdr d))))))

(define (edits d)
  (let loop ((d d))
    (cond ((atom? d) d)
          ((eq? (car d) #:old)
           (cons (string-append (red "-") (red (->string (cadr d))))
                 (loop (cddr d))))
          ((eq? (car d) #:new)
           (cons (string-append (green "+") (green (->string (cadr d))))
                 (loop (cddr d))))
          (else
           (cons (loop (car d))
                 (loop (cdr d)))))))

(let ((diff (difference (expected "examples.scm") (actual "examples.scm"))))
  (test-assert "examples.scm" (null? diff))
  (for-each (lambda (x)
              (when (pair? x) (display " "))
              (print x))
            (edits diff)))

(test-exit)