;;; (yolk colors) --- ansi color escapes

;; "Colors" in this context refers both to actual /colors/, and to text
;; properties like bold, italic, etc.

(import (scheme base)
        (scheme write)
        (chicken string)
        (matchable)                     ; is this something i want?
        (yolk common))

(define (%colors . codes)
  (let ((codestr (string-intersperse (map ->string codes) ";")))
    (csi codestr "m")))

(define %props-alist
  '((reset . "0")
    ;; name . (on . off)
    (bold . ("1" . "22"))
    (dim . ("2" . "22"))
    (italic . ("3" . "23"))
    (underline . ("4" . "24"))
    (blink . ("5" . "25"))
    (inverse . ("7" . "27"))
    (hidden . ("8" . "28"))
    (strikethrough . ("9" . "29"))))

(define %colors-alist
  '((reset . "0")
    ;; color . (fg . bg)
    (black . ("30" . "40"))
    (red . ("31" . "41"))
    (green . ("32" . "42"))
    (yellow . ("33" . "43"))
    (blue . ("34" . "44"))
    (magenta . ("35" . "45"))
    (cyan . ("36" . "46"))
    (white . ("37" . "47"))
    (default . ("39" . "49"))))

(define (atom? x)
  (and (not (pair? x))
       (not (null? x))))

(define (colors-reset . codes)
  (cond
   ((null? codes)
    (%colors 0))
   (else (apply string-append
                (map (lambda (code)
                       (match code
                         ('fg (%colors (cadr (assq 'default %colors-alist))))
                         ('bg (%colors (cddr (assq 'default %colors-alist))))
                         (x (%colors (cddr (assq x %props-alist))))))
                     codes)))))

(define (color? x)
  (memq x '(default black red green yellow blue magenta cyan white)))

(define (colors codes)
  (let loop ((codes codes)
             (acc '()))
    (if (null? codes)
        (apply %colors (reverse acc))
        (loop (cdr codes)
              (match (car codes)
                ((? number? x)
                 (cons x acc))
                ((or `(fg ,color)
                     (? color? color))
                 (cons (cadr (assq color %colors-alist))
                       acc))
                (`(bg ,color)
                 (cons (cddr (assq color %colors-alist))
                       acc))
                ((or `(set ,prop)
                     `(,prop on)
                     (? atom? prop))
                 (cons (cadr (assq prop %props-alist))
                       acc))
                ((or `(reset ,prop)
                     `(,prop off))
                 (cons (cddr (assq prop %props-alist)))))))))

(define (with-colors codes thunk)
  (dynamic-wind
    (lambda () (display (colors codes)))
    thunk
    (lambda () (display (colors-reset)))))